From 777c9040543cbba5a91654c058fa4233b78c117c Mon Sep 17 00:00:00 2001 From: Lassi Kortela Date: Sat, 20 May 2023 12:57:06 +0300 Subject: [PATCH] Unpack disk3.tgz --- conio.h | 16 + ctype.h | 66 ++ dos.h | 476 ++++++++ dos.mac | 193 +++ freesp.equ | 2 + math.h | 167 +++ memtype.equ | 17 + memtype.h | 17 + pcmake.equ | 12 + pcmake.h | 10 + prosprin.asm | 1403 ++++++++++++++++++++++ prosread.asm | 888 ++++++++++++++ prowin.asm | 548 +++++++++ realio.asm | 1903 ++++++++++++++++++++++++++++++ realio.equ | 90 ++ realschm.asm | 1357 +++++++++++++++++++++ regschem.h | 290 +++++ rpc.equ | 37 + saprop.asm | 247 ++++ sasm.mac | 564 +++++++++ sbid.asm | 512 ++++++++ sbigmath.asm | 707 +++++++++++ sc.asm | 1277 ++++++++++++++++++++ scannum.asm | 453 +++++++ scar_cdr.asm | 651 ++++++++++ schars.h | 18 + scheme.equ | 5 + scheme.h | 4 + schemed.asm | 607 ++++++++++ schemed.equ | 539 +++++++++ schemed.mac | 99 ++ schmdefs.h | 309 +++++ screen.equ | 4 + scroll.asm | 114 ++ senv.asm | 1052 +++++++++++++++++ sexec.asm | 91 ++ sgcmark.asm | 329 ++++++ sgcsweep.asm | 335 ++++++ sinterp.arg | 27 + sinterp.asm | 3213 ++++++++++++++++++++++++++++++++++++++++++++++++++ sinterp.mac | 20 + sio.asm | 292 +++++ slink.h | 35 + slist.h | 25 + smmu.asm | 173 +++ smmu.mac | 301 +++++ sobjhash.asm | 458 +++++++ sport.h | 136 +++ squish.asm | 753 ++++++++++++ srch_str.asm | 1359 +++++++++++++++++++++ srelocat.asm | 490 ++++++++ sstack.asm | 1807 ++++++++++++++++++++++++++++ sstring.asm | 518 ++++++++ stackf.equ | 55 + stdio.h | 173 +++ stimer.asm | 118 ++ strmlnrs.asm | 679 +++++++++++ sutil.asm | 802 +++++++++++++ svars.asm | 958 +++++++++++++++ sw_int.asm | 46 + version.h | 16 + xli.asm | 1371 +++++++++++++++++++++ xli.equ | 70 ++ xli.mac | 181 +++ xli_pro.mac | 185 +++ zio.asm | 850 +++++++++++++ 66 files changed, 30520 insertions(+) create mode 100644 conio.h create mode 100644 ctype.h create mode 100644 dos.h create mode 100644 dos.mac create mode 100644 freesp.equ create mode 100644 math.h create mode 100644 memtype.equ create mode 100644 memtype.h create mode 100644 pcmake.equ create mode 100644 pcmake.h create mode 100644 prosprin.asm create mode 100644 prosread.asm create mode 100644 prowin.asm create mode 100644 realio.asm create mode 100644 realio.equ create mode 100644 realschm.asm create mode 100644 regschem.h create mode 100644 rpc.equ create mode 100644 saprop.asm create mode 100644 sasm.mac create mode 100644 sbid.asm create mode 100644 sbigmath.asm create mode 100644 sc.asm create mode 100644 scannum.asm create mode 100644 scar_cdr.asm create mode 100644 schars.h create mode 100644 scheme.equ create mode 100644 scheme.h create mode 100644 schemed.asm create mode 100644 schemed.equ create mode 100644 schemed.mac create mode 100644 schmdefs.h create mode 100644 screen.equ create mode 100644 scroll.asm create mode 100644 senv.asm create mode 100644 sexec.asm create mode 100644 sgcmark.asm create mode 100644 sgcsweep.asm create mode 100644 sinterp.arg create mode 100644 sinterp.asm create mode 100644 sinterp.mac create mode 100644 sio.asm create mode 100644 slink.h create mode 100644 slist.h create mode 100644 smmu.asm create mode 100644 smmu.mac create mode 100644 sobjhash.asm create mode 100644 sport.h create mode 100644 squish.asm create mode 100644 srch_str.asm create mode 100644 srelocat.asm create mode 100644 sstack.asm create mode 100644 sstring.asm create mode 100644 stackf.equ create mode 100644 stdio.h create mode 100644 stimer.asm create mode 100644 strmlnrs.asm create mode 100644 sutil.asm create mode 100644 svars.asm create mode 100644 sw_int.asm create mode 100644 version.h create mode 100644 xli.asm create mode 100644 xli.equ create mode 100644 xli.mac create mode 100644 xli_pro.mac create mode 100644 zio.asm diff --git a/conio.h b/conio.h new file mode 100644 index 0000000..f5ceaff --- /dev/null +++ b/conio.h @@ -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 + \ No newline at end of file diff --git a/ctype.h b/ctype.h new file mode 100644 index 0000000..edf71bd --- /dev/null +++ b/ctype.h @@ -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 + diff --git a/dos.h b/dos.h new file mode 100644 index 0000000..582562c --- /dev/null +++ b/dos.h @@ -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 + diff --git a/dos.mac b/dos.mac new file mode 100644 index 0000000..cd41b6c --- /dev/null +++ b/dos.mac @@ -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 + diff --git a/freesp.equ b/freesp.equ new file mode 100644 index 0000000..79829bd --- /dev/null +++ b/freesp.equ @@ -0,0 +1,2 @@ +dog equ 1 + \ No newline at end of file diff --git a/math.h b/math.h new file mode 100644 index 0000000..93f424e --- /dev/null +++ b/math.h @@ -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 + diff --git a/memtype.equ b/memtype.equ new file mode 100644 index 0000000..5156db3 --- /dev/null +++ b/memtype.equ @@ -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 + \ No newline at end of file diff --git a/memtype.h b/memtype.h new file mode 100644 index 0000000..dd31952 --- /dev/null +++ b/memtype.h @@ -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 + \ No newline at end of file diff --git a/pcmake.equ b/pcmake.equ new file mode 100644 index 0000000..dcefb2e --- /dev/null +++ b/pcmake.equ @@ -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 + \ No newline at end of file diff --git a/pcmake.h b/pcmake.h new file mode 100644 index 0000000..fa58b55 --- /dev/null +++ b/pcmake.h @@ -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 + \ No newline at end of file diff --git a/prosprin.asm b/prosprin.asm new file mode 100644 index 0000000..814d744 --- /dev/null +++ b/prosprin.asm @@ -0,0 +1,1403 @@ +; ======> PROSPRIN.ASM +;************************************************************************ +;* PC Scheme Runtime Support - Sexpression Print Routines * +;* * +;* (C) Copyright 1985 by Texas * +;* Instruments Incorporated. * +;* All rights reserved. * +;* * +;* Date Written: 24 March 1986 * +;* * +;* Modifications: * +;* * +;* 11/27/87 (tc) Rewritten for protected mode scheme. Also * +;* modified to buffer the output more effectively. * +;* * +;************************************************************************ + page 60,132 + title PC Scheme Print Handlers + include scheme.equ + include sinterp.arg + include xli_pro.mac + +NUMBER_SPECIAL_CHARS equ 8 ;special chars defined in cread.asm + +RETURN equ 0Dh +SPACE equ 20h +SYM_OVHD equ 7 +HEAPERR equ -3 + +DGROUP group data +data segment word public 'DATA' + assume DS:DGROUP + public display, show, ccount +;from sread.asm + extrn test_ch:word + extrn t_array:word +;from xli_pro.asm + extrn rpc_handle:byte + extrn REAL_MODE_BUFFER:dword + extrn REAL_BUF_OFFSET:word,REAL_BUF_SELECTOR:word + extrn REAL_BUF_PARA:word,REAL_BUF_TOP:WORD +;from iosupport.asm + extrn port_seg:word,port_pg:word,port_ds:word +;from ??? + extrn hicases:byte + +;Table of strange characters used by printatm +stranges db " ,'" + db ';":()`' + db 13,12,11,10,9,0 + +; +; The following global data is used to tell the print handlers about +; the print characteristics, ie. to surround strings with double quotes, +; to display escape characters, etc. +; +; +display dw 0 ; whether to surround atoms/strings with | or " +show dw 1 ; whether actually printing chars or not +ccount dw 0 ; char count used to determine print length + +; +; Branch table of all Scheme object print handlers +; +branchtab dw sp_list ; [0] LISTTYPE + dw sp_fix ; [1] FIXTYPE + dw sp_flo ; [2] FLOTYPE + dw sp_big ; [3] BIGTYPE + dw sp_sym ; [4] SYMTYPE + dw sp_str ; [5] STRTYPE + dw sp_ary ; [6] ARYTYPE + dw sp_cont ; [7] CONTTYPE + dw sp_clos ; [8] CLOSTYPE + dw sp_free ; [9] FREETYPE + dw sp_code ; [10] CODETYPE + dw subp_ret ; [11] REFTYPE + dw sp_port ; [12] PORTTYPE + dw sp_char ; [13] CHARTYPE + dw sp_env ; [14] ENVTYPE + +; +; Following text will be output for those objects which have not +; printable representations. +; +port_str db "#",0 +parens db "()",0 +cont_str db "#",0 +ary_str db "#(" +free_str db "#",0 +code_str db "#",0 +env_str db "#",0 +clos_str db "#",0 +ab_write db "[WARNING: Output aborted by SHIFT-BREAK]",0 +bad_set db "[VM INTERNAL ERROR] setadr: bad port",CR,LF,0 + +data ends + +PGROUP group prog +prog segment byte public 'PROG' + assume CS:PGROUP + extrn next_SP:near + extrn src_err:near + extrn get_port:near + extrn setabort:near,abort:near + extrn take_cdr:near,restart:near,stkspc:near + extrn copybig:near,fix2big:near,big2asc:near,get_flo:near + extrn isspace:near + extrn gvchars:near,ssetadr:near + extrn scannum:near + +comment | Commented out 2/10/88 by TC - moved to realio routine + +;****************************************************************************** +;WRAP - Local macro definition. If there are less than LEN spaces left on +; the local output line, make AX non-zero to denote wrap necessary. +; +; Note: es:di are destroyed +;****************************************************************************** +wrap macro len,result + local wrapend + push es + push di + xor result,result ;result = default no wrap + cmp show,0 ;are we actually printing? + jz wrapend ; no, just return with default + LoadPage es,port_pg + mov di,port_ds ;es:di => port object + cmp es:[di].pt_ncols,0 ;maintaining line length? + jz wrapend ; no, return default + cmp es:[di].pt_ccol,1 ;in the first column already? + jle wrapend ; yes, return default + mov result,es:[di].pt_ncols ;ax = number cols + sub result,es:[di].pt_ccol ;ax = remaining spaces + cmp result,len ;any room left? + mov result,0 ; + jge wrapend ; yes, return nowrap flag + inc result ; no, return wrap flag +wrapend: + pop di + pop es + endm + +| + +prn_proc proc near +;;;**************************************************************************** +;;; VM Opcode handler for "WRITE" +;;; +;;; Print an S-Expression with slashification +;;; +;;;**************************************************************************** + public spprin1 +spprin1: lods word ptr ES:[SI] ; load register operand + save + xor BX,BX + mov BL,AH + add BX,offset reg0 ; BX = port object + xor AH,AH + add AX,offset reg0 ; AX = s-expression pointer + mov DI,AX + save + mov CX,1 ; write indicator + pushm + C_call get_port,,Load_ES ; get port address + mov SP,BP + test AX,AX ; check return status + jz sp1_010 + lea BX,sp1_er + jmp src_err ; link to error handler +sp1_010: + inc AX + mov display,AX + mov show,AX + pushm + restore + mov BX,[DI].C_page + shr BX,1 + pushm <[DI].C_disp, BX> + call sprint ; write + mov SP,BP +sp1_020: restore ; get the register pointer + mov [DI].C_page,NPR_PAGE*2 ; return as non-printable object + mov [DI].C_disp,NPR_DISP + mov display,0 ; default display = no + jmp next_SP ; return to interpreter +;;;**************************************************************************** +;;; VM Opcode handler for "DISPLAY" +;;; +;;; Print an S-Expression without slashification +;;; +;;;**************************************************************************** + public spprinc +spprinc: lods word ptr ES:[SI] ; load register operand + save + xor BX,BX + mov BL,AH + add BX,offset reg0 ; BX = port object + xor AH,AH + add AX,offset reg0 ; AX = s-expression pointer + mov DI,AX + save + mov CX,1 + pushm + C_call get_port,,Load_ES ; get port address + mov SP,BP + test AX,AX ; check return status + jz spc_010 + lea BX,spc_er + jmp src_err ; link to error handler +spc_010: mov display,AX + inc AX + mov show,AX + pushm + restore + mov BX,[DI].C_page + shr BX,1 + pushm <[DI].C_disp, BX> + call sprint ; display + mov SP,BP + jmp sp1_020 +;;;**************************************************************************** +;;; VM Opcode handler for "PRINT" +;;; +;;; Print an S-Expression with spacing control +;;; +;;;**************************************************************************** + public spprint +spprint: lods word ptr ES:[SI] ; load register operand + save + xor BX,BX + mov BL,AH + add BX,offset reg0 ; BX = port object + xor AH,AH + add AX,offset reg0 ; AX = s-expression pointer + mov DI,AX + save + mov CX,1 + pushm + C_call get_port,,Load_ES ; get port address + mov SP,BP + test AX,AX ; check return status + jz spt_010 + lea BX,spt_er + jmp src_err ; link to error handler +spt_010: mov display,AX + inc AX + mov show,AX + mov DX,SPECCHAR + mov BX,RETURN ; carriage return + pushm + call sprint ; print it + mov SP,BP + xor AX,AX + inc AX + mov show,AX + mov display,AX + pushm + restore + mov BX,[DI].C_page + shr BX,1 + pushm <[DI].C_disp, BX> + call sprint ; print the s-expression + mov SP,BP + mov BX,SPACE + mov DX,SPECCHAR ; space + xor AX,AX + mov display,AX + inc AX + mov show,AX + pushm + call sprint ; print it + mov SP,BP + jmp sp1_020 +;;;**************************************************************************** +;;; VM Opcode handler for "NEWLINE" +;;; +;;; Output a newline character +;;; +;;;**************************************************************************** + public spnewlin +spnewlin: lods byte ptr ES:[SI] ; load register operand + save + add AX,offset reg0 ; AX = port object + mov CX,1 + pushm + C_call get_port,,Load_ES ; get port address + mov SP,BP + test AX,AX ; check return status + jz new_010 + lea BX,new_er + jmp src_err ; link to error handler +new_010: mov display,AX + inc AX + mov show,AX + mov BX,SPECCHAR + mov DX,RETURN ; carriage return + pushm + call sprint + mov SP,BP + mov display,0 ; default display = no + jmp next_SP ; return to interpreter +;;;**************************************************************************** +;;; VM Opcode handler for "LINE-LENGTH" +;;; +;;; Determine the print length of a scheme object +;;; +;;;**************************************************************************** + public prt_len +prt_len: lods byte ptr ES:[SI] ; load register operand + save + add AX,offset reg0 ; AX = port object + mov DI,AX + xor CX,CX + mov display,CX ; no display and show + mov show,CX + save + mov DX,OUT_PAGE*2 + mov CX,OUT_DISP + mov BX,[DI].C_page + shr BX,1 ; correct page number + pushm + call sprint + mov SP,BP ; AX = print length + restore + mov [DI].C_page,SPECFIX*2 + mov [DI].C_disp,AX ; get the print length + jmp next_SP ; return to interpreter +prn_proc endp + +;************************************************************************** +; SPRINT - Sexpression print routine +; +; Calling Sequence: sprint(pds,ppg,dis,pg) +; +; Where: ppg:pds = page:displacement of port to output to +; pg:dis = scheme object to output +; +; Upon Exit: AX = number of characters printed +; +;************************************************************************** + +spt_arg struc + dw ? ;caller's BP + dw ? ;caller's return address +pg dw ? ;page num of object to print +dis dw ? ;page disp of object to print +ppg dw ? ;page num of output port +pds dw ? ;page disp of output port +spt_arg ends + + public sprint +sprint proc near + push BP + mov BP,SP ;set up stack + call setabort ;set address when abort + pushm <[BP].pds, [BP].ppg> + call ssetadr ;set port address + mov SP,BP + +;fix for random i/o - note a write has taken place + mov AX,ES ;save extra segment + LoadPage ES,port_pg ;address port + mov SI,port_ds + or byte ptr ES:[SI].pt_pflgs,DIRTY ;note write has occurred + mov ES,AX ;restore extra segment + + mov ccount,0 ;clear character count + pushm <[BP].dis, [BP].pg> + call subsprin ;go print the object + mov SP,BP + mov AX,ccount ;return number of characters + pop BP + ret ;return to caller +sprint endp + +;************************************************************************** +; SUBSPRIN - Recursive print routine +; +; Calling Sequence: subsprin(dis,pg) +; +; Where: dis = displacement with pg of object to print +; pg = page of object to print +; +;************************************************************************** + public subsprin +subp_arg struc +tmp_reg1 dw ? +tmp_reg2 dw ? +tmp_reg3 dw ? +lst_pag dw ? +lst_dsp dw ? +subp_BP dw ? ; caller's BP + dw ? ; caller's ES + dw ? ; caller's return address +spg dw ? ; page number +sdis dw ? ; displacement +subp_arg ends + +subsprin proc near + push ES + push BP + sub SP,offset subp_BP ;allocate local storage + mov BP,SP + cmp s_break,0 ;check for SHIFT-BREAK + je subp_10 +kill_out: mov AX,RETURN ;carriage return + call printcha + mov AX,41 ;length of message + lea BX,ab_write + pushm + call printtxt ;display message + mov SP,BP + cmp show,0 + je kill_01 + xor AX,AX + jmp kill_02 +kill_01: mov AX,2 +kill_02: push AX ;instruction length + C_call restart ;link to scheme debugger + ;control does not return to here +subp_10: call stkspc ;check stack space + cmp AX,64 ;stack low? + jge subp_20 ;no, jump + mov AX,8 + lea BX,deep_str ;# + jmp subp_ret ;print message and return +; act on object type +subp_20: + shl [BP].spg,1 ;adjust page number + mov BX,[BP].spg + mov DI,ptype+[BX] ;get page type + jmp branchtab+[DI] ;envoke appropriate handler +; +; any problems with getmem should exit here +mem_err: + mov AX,HEAPERR ;memory not available + push AX + call abort + mov SP,BP +; +; return to caller +subp_ret: + add SP,offset subp_BP ;release local storage + pop BP + pop ES + ret + + + page 60,132 +;----------------------------------------------------------------------------- +; +; Following are the print handlers for each object type, they will be invoked +; via an indirect call through BRANCHTAB. +; +; Upon entry: BX = an adjusted page number +; DI = the page type +; +; Upon exit: Jump to SUBP_RET for cleanup +; +;----------------------------------------------------------------------------- + +;******************************************************************************* +; +; Print representation for code block object +; +;******************************************************************************* + public sp_code +sp_code: mov AX,7 + lea BX,code_str ; # + jmp subp_txt +;******************************************************************************* +; +; Print representation for continuation object +; +;******************************************************************************* + public sp_cont +sp_cont: mov AX,15 + lea BX,cont_str ; # + jmp subp_txt +;******************************************************************************* +; +; Print representation for environment object +; +;******************************************************************************* + public sp_env +sp_env: mov AX,14 + lea BX,env_str ; # + jmp subp_txt +;******************************************************************************* +; +; Print representation for free page +; +;******************************************************************************* + public sp_free +sp_free: mov AX,7 + lea BX,free_str ; # + jmp subp_txt +;******************************************************************************* +; +; Print representation for port object +; +;******************************************************************************* + public sp_port +sp_port: mov AX,7 + lea BX,port_str ; # +subp_txt: + pushm ;ax = length, bx = message address + call printtxt ;print the message + mov SP,BP ;clean up stack + jmp subp_ret ;and return to caller + +;******************************************************************************* +; +; Print floating point value +; +;******************************************************************************* + public sp_flo +sp_flo: mov SI,[BP].sdis ; displacement + shr BX,1 ; corrected page number + pushm + call get_flo ; get a floating point value + pushm ; in AX:BX:CX:DX + C_call printflo,,Load_ES + mov SP,BP + jmp subp_ret + +;******************************************************************************* +; +; Print list +; +;******************************************************************************* + public sp_list +sp_list: + test bx,bx ;null page? + jnz sp_l01 ; no, go chase list + mov ax,2 + lea bx,parens + pushm + call printtxt ;print "()" for null list + mov sp,bp + jmp subp_ret +sp_l01: + mov al,byte ptr parens + call printcha ;print open paren + mov bx,[bp].spg + LoadPage es,bx + mov si,[bp].sdis ;es:si => list cell +sp_l02: + mov [bp].lst_pag,bx + mov [bp].lst_dsp,si ;save list cell + xor dh,dh + mov dl,byte ptr es:[si] ;get car of list + shr dx,1 ; make number for subsprin + mov cx,word ptr es:[si+1] ;get car's displacement + pushm + call subsprin ;print car of list + mov sp,bp + mov bx,[bp].lst_pag ;restore list cell + LoadPage es,bx + mov si,[bp].lst_dsp + mov bl,byte ptr es:[si+3] ;get cdr of list + mov si,word ptr es:[si+4] + test bx,bx ;is it null? + jz sp_l04 ; yes, finished + pushm ;tempsave si,bx + mov al,' ' + call printcha ;print space as item seperator + popm ;restore stack + LoadPage es,bx ;reload page of cdr + cmp byte ptr ptype+[bx],LISTTYPE*2 ;is cdr a list cell? + je sp_l02 ; yes, chase the list +; cdr is not a list cell - improper list + mov dx," ." ;need " ." due to byte swapping + pushm ;tempsave si,bx - dx is text + mov si,sp + mov dx,2 + pushm ;push length, address of text + call printtxt ;print ". " + add sp,6 ;dump last 3 args + popm ;restore saved regs + + shr bx,1 ;make page a number for subsprin + pushm + call subsprin ;go chase last cdr + mov sp,bp ;dump args off stack +sp_l04: + mov al,byte ptr parens+1 + call printcha ;and print it + mov sp,bp + jmp subp_ret ;return to caller + +;******************************************************************************* +; +; Print array +; +;******************************************************************************* + public sp_ary +sp_ary: mov AX,2 + LoadPage ES,BX ; page segment + lea BX,ary_str ; print "#(" + pushm + call printtxt + mov SP,BP + + LoadPage ES,[BP].spg ; Get page address of array +;;; mov ES,word ptr pagetabl+[BX] + mov SI,[BP].sdis ; and segment + mov CX,word ptr ES:[SI+1] + sub CX,BLK_OVHD ; length of array + mov BX,BLK_OVHD + mov [BP].tmp_reg1,CX +sp_a01: + cmp BX,[BP].tmp_reg1 + jle sp_a04 + jmp sp_l04 +sp_a04: mov AL,byte ptr ES:[SI+BX] ; AX <= page of array element + mov DX,word ptr ES:[SI+BX+1] ; DX <= disp. of array element + xor AH,AH + shr AX,1 ; Page number for subsprin + mov [BP].tmp_reg2,BX ; Save registers + mov [BP].lst_dsp,SI + pushm + call subsprin ; print element + mov SP,BP + mov BX,[BP].tmp_reg2 ; restore BX + cmp BX,[BP].tmp_reg1 ; last element? + jge sp_a02 + mov ax,SPACE ; print ' ' + call printcha + mov BX,[BP].tmp_reg2 ; restore registers +sp_a02: mov SI,[BP].lst_dsp + add BX,PTRSIZE + LoadPage ES,[BP].spg ; Reload page address of array + jmp sp_a01 +;******************************************************************************* +; +; Print representation for closure object +; +;******************************************************************************* + public sp_clos +sp_clos: mov ax,11 + lea bx,clos_str + pushm + call printtxt ;print "# closure object + lea bx,[bp].tmp_reg1 + xor ah,ah + mov al,byte ptr es:[si+3] ;pag # of information op + mov [bx].C_page,ax ; save in tmp_reg1 + mov ax,word ptr es:[si+4] ;displ of information op + mov [bx].C_disp,ax ; save in tmp_reg1 +; follow info operand list +sp_c001: + mov di,[bx].C_page + cmp di,0 ;if reached end of list + je sp_c04 ; then exit loop + cmp byte ptr ptype+[di],LISTTYPE*2 ;if cdr not list cell + jne sp_c01 ; then exit loop + push bx + call take_cdr ;follow cdr of list + lea bx,[bp].tmp_reg1 + jmp sp_c001 +; If final operand is a symbol, print it +sp_c01: + cmp byte ptr ptype+[DI],SYMTYPE*2 ;do we have a symbol? + jne sp_c04 ; no, jump + + push bx ;tempsave reg around call + mov ax,SPACE + call printcha ;print ' ' + pop bx ;restore reg + + push display ;save around call + mov display,0 ;don't print escape chars + shr [bx].C_page,1 ;make page # for subsprin + pushm <[bx].C_disp,[bx].C_page> ;push page:disp of symbol + call subsprin ;go print the symbol + add sp,4 ;dump args off stack + pop display ;restore display indicator +sp_c04: + mov al,'>' + call printcha ;print '>' + mov SP,BP + jmp subp_ret + +;******************************************************************************* +; +; Print symbol to output port +; +;******************************************************************************* + public printatm +printatm label near +sp_sym: +; +; Warning: local data segment is not used in code below +; + loadpage ds,bx + mov si,[bp].sdis ;ds:si => object + mov cx,[si]+1 ;get object length + sub cx,SYM_OVHD ;cx = length of atom + add SS:ccount,cx ;update character count + cmp SS:show,0 ;do we want to print the object? + jne pra_010 ; yes, continue + mov dx,ss ; no, restore data segment + mov ds,dx + jmp pra_exit ; and return +pra_010: + ;cx = length of symbol + add si,SYM_OVHD ;ds:si => symbol name + GET_BUFFER ;es:di => real buffer + call atm2pbuf ;move printname to print buffer +; +; Warning: local data segment is not used in code above +; + mov dx,ss + mov ds,dx ;restore local data segment + cmp cx,0 ;if negative print length + jl pra_err ; then error, jump +;;; wrap cx,dx ;cx = length, dx = result + mov dx,1 ;check wrap flag +;cx = length, dx = check wrap flag, es:di => print buffer + call gvchars ;go print the buffer +pra_exit: + RLS_BUFFER + jmp subp_ret +pra_err: + jmp mem_err + +;******************************************************************************* +; +; Print string to output port +; +;******************************************************************************* + public printstr +printstr label near +sp_str: +; +; Warning: local data segment is not used in code below +; + loadpage ds,bx + mov si,[bp].sdis ;ds:si => object + mov cx,[si]+1 ;cx = length indicator + add si,BLK_OVHD ;ds:si => actual string + or cx,cx ;small string? + jge prs_005 ; no, jump + add cx,BLK_OVHD+PTRSIZE +prs_005: + sub cx,BLK_OVHD ;cx = length of string + add SS:ccount,cx ;update character count + cmp SS:show,0 ;actually printing? + jne prs_010 ; yes, continue + mov dx,ss ; no, restore data segment + mov ds,dx + jmp pra_exit ; and return +prs_010: + + ;cx = string length + GET_BUFFER ;es:di => buffer for print string + call str2pbuf ;move string to print buffer +; +; Warning: local data segment is not used in code above +; + mov bx,ss ;restore local data segment + mov ds,bx + cmp cx,0 ;if negative print length + jl prs_err ; then error, jump +;;; wrap cx,dx ;cx=length, dx=result + mov dx,1 ;check wrap flag +;cx = length, dx = check wrap flag, es:di => print buffer + call gvchars ;go print the buffer +prs_exit: + RLS_BUFFER ;release the print buffer + jmp subp_ret + +prs_err: jmp mem_err ;must be a long jump + + +;******************************************************************************* +; +; Print character to output port +; +;******************************************************************************* + public sp_char +sp_char: + cmp display,0 ;display escape chars? + jne sp_ch10 ; yes, jump +;print character without escapes + mov ax,[BP].sdis ;get character + xor ah,ah + call printcha ;call print routine + jmp subp_ret ;get outa here +;print character with escapes +sp_ch10: + mov bx,14 ;max size of character buffer + push bx + C_call getmem ;allocate space + mov sp,bp ;dump arg off stack + cmp ax,0 + jne sp_ch00 + jmp mem_err ;error allocating heap - jump +sp_ch00: + mov si,ax ;si => buffer + mov dx,ax ;dx => buffer + mov ax,[BP].sdis ;get character + mov byte ptr [si],23h ; # + mov byte ptr [si+1],5Ch ; \ + mov byte ptr [si+2],AL ;character + mov byte ptr [si+3],0 ;end of string + mov bx,3 ;length +; +; see if character one of the multi-character constants in cread.asm +; + mov cx,ds + mov es,cx ;ensure ds=es + + mov cx,NUMBER_SPECIAL_CHARS ;cx = counter + lea di,test_ch + add di,NUMBER_SPECIAL_CHARS-1 ;di => last special char + std + repne scasb ;search for special char + cld + jnz sp_ch20 ;if none found, jump + shl cx,1 ;make index into t_array + + lea di,t_array + add di,cx + mov di,[di] + xchg si,di ;ds:si => character string + add di,2 ;es:di => character buffer + cld + xor al,al ;al = null terminator +sp_chlp: + movsb ;move byte into character buffer + cmp al,[si] ;reached terminator? + jne sp_chlp + sub di,dx ;calc length + mov bx,di +sp_ch20: + pushm ;bx=buffer length, dx=buffer address + call printtxt ;print the character constant + mov SP,BP + + mov bx,14 ;length of character buffer + pushm + C_call rlsmem ;release character buffer + mov sp,bp ;dump args off stack + jmp subp_ret + +;******************************************************************************* +; +; Print integer value +; +;******************************************************************************* + public sp_fix +sp_fix: mov AX,5 + mov [BP].tmp_reg2,AX + push AX + C_call getmem + mov SP,BP + or ax,ax + jnz sp_f10 + jmp mem_err +sp_f10: + mov [BP].tmp_reg1,AX ; address of divider + mov SI,[BP].sdis ; get the value + shl SI,1 + sar SI,1 + pushm + mov AX,DS + mov ES,AX ; get the right ES segment + call fix2big ; change to bignum + mov SP,BP + jmp printint +;******************************************************************************* +; +; Print bignum +; +;******************************************************************************* + public sp_big +sp_big: LoadPage ES,BX + mov SI,[BP].sdis + mov AX,word ptr ES:[SI+1] ; get object size + dec AX + mov [BP].tmp_reg2,AX + push AX + C_call getmem ; allocate memory for divider + mov SP,BP + cmp AX,0 ; memory available? + jne sp_big1 + jmp mem_err ; no, error +sp_big1: mov [BP].tmp_reg1,AX ; address of divider + mov BX,[BP].spg + shr BX,1 + pushm + mov AX,DS + mov ES,AX ; get the right ES segment + call copybig ; copy bignum to buffer +printint: + mov AX,[BP].tmp_reg2 + mov BX,3 + mul BX + sub AX,5 + mov [BP].lst_dsp,AX + push AX + C_call getmem ; allocate memory for char buffer + mov SP,BP + cmp AX,0 ; memory available? + jne sp_big2 + jmp mem_err ; no, error +sp_big2: mov [BP].tmp_reg3,AX ; address of bigchars + pushm + call big2asc ; convert bignum to char string + mov SP,BP ; AX = characters count + pushm + call printtxt ; print the bignum + mov SP,BP + pushm <[BP].tmp_reg2, [BP].tmp_reg1> + C_call rlsmem + pushm <[BP].lst_dsp, [BP].tmp_reg3> + C_call rlsmem + mov SP,BP + jmp subp_ret + +subsprin endp + + +; page 60,132 +; title Print Handler Support Routines +; +;****************************************************************************** +;PRINTTXT - C callable routine to print a string, first sending a newline +; character if necessary. The string is assumed to be in the +; local data segment. +; +; Calling Sequence: printtxt(string,len) +; +;****************************************************************************** +str_arg struc + dw ? ; caller's BP + dw ? ; caller's ES + dw ? ; caller's return address +str dw ? ; string pointer +len dw ? ; string length +str_arg ends + public printtxt +printtxt proc near + push es + push bp + mov bp,sp ;set up stack + + mov cx,[bp].len ;cx = length of string + add ccount,cx ;keep track of character count + cmp show,0 ;show? + je pstr_ret ; no, return + + push display + mov display,0 + mov si,[bp].str ;ds:si => string to write + GET_BUFFER ;es:di => buffer for print string + call str2pbuf ;move string to print buffer + pop display + +;;; wrap cx,dx ;cx=length, dx=result + mov dx,1 ;check wrap flag +;cx = length, dx = check wrap flag, es:di => print buffer + call gvchars ;go print the buffer + RLS_BUFFER ;release the print buffer +pstr_ret: + pop bp + pop es + ret +printtxt endp + + +;****************************************************************************** +;PRINTCHA - C callable routine to print a character, first sending a newline +; character if necessary. At least for now, this is performed by +; calling gvchars - in the future we may want output routines for +; outputting individual characters. +; +; Upon Entry: al contains character to print +; +;****************************************************************************** +pcha_arg struc + dw ? ;caller's BP + dw ? ;caller's ES + dw ? ;caller's return address +pcha_arg ends + + public printcha +printcha proc near + push es + push bp + mov bp,sp ;set up stack + + inc ccount ;bump character count + cmp show,0 ;if not actually printing + jz pcha_ret ; then return + +comment | +;see if enough space left on current output line + LoadPage es,port_pg + mov di,port_ds ;es:di => port object + xor dx,dx ;dx = wrap flag (0 = nowrap) + mov cx,es:[di].pt_ncols ;maintaining line length? + jcxz pcha_010 + sub cx,es:[di].pt_ccol ;cx = space remaining + cmp cx,1 ;any space left? + jge pcha_010 + mov dx,1 + | + mov dx,1 ;check wrap flag +pcha_010: + RESET_REAL_BUFFER_OFFSET + MOVE_BYTE_TO_BUF al,REAL_MODE_BUFFER + mov cx,1 ;cx = length + call gvchars +pcha_ret: + xor ax,ax + pop bp + pop es + ret +printcha endp + +COMMENT % + The two routines below are written such that they may run either on the + hummingboard or out of 286/386 pritected memory. The hummingboard cannot + directly address the host's physical memory, so when displaying escape + chars within a string, it is first buffered into space allocated in the + heap, then written via a block move to the print buffer. Although this is + somewhat clumsy, it significantly improves performance over writing + individual bytes to the print buffer with the BLOCK-MOVE dos function + provided by OSx86. + If in the future the hummingboard os traps instructions which are writing + to real memory, then the buffering may be discarded and simple memory + moves may be performed. +% + +;****************************************************************************** +;ATM2PBUF - Move symbol printname to printbuffer +; +; Description: +; The symbol name pointed to by ds:si is moved into a print buffer for output. +; +; If the display flag is set, the symbol is being output by the "write" lisp +; function and all backslashes and vertical bars (\,|) are written to the +; buffer preceeded by a backslash. In addition, the symbol must also be +; surrounded by vertical bars (|) if lowercase letters, commas, semi-colons, +; and other strange characters are encountered; or if the printname is a +; ".", a name starting with a # (other than special symbols), or is numeric. +; +; If the display flag is not set, then the printname is moved to the buffer +; without performing any translation. +; +; Upon Entry: +; cx = length of printname +; ds:si => printname +; es:di => print buffer +; +; Upon Exit: +; cx = # characters placed in print buffer +; es:di => print buffer +; +;****************************************************************************** +p_struc struc +dest_top dw ? +dest_start dw ? +heap_top dw ? +heap_str dd ? +src_start dw ? +src_str dd ? +dest_str dd ? +stlen dw ? +call_bp dw ? +p_struc ends + + public atm2pbuf +atm2pbuf proc near + BUFFER_IS_BUFFER ;real mode buffer treated as such + + cmp ss:display,0 ;displaying escape chars? + jnz a2p_xlat ; yes, jump +;move printname to print buffer + MOVE_TO_REAL_BUF ;move entire string over + ret ;return to caller +a2p_err: + mov [bp].stlen,-1 + jmp a2p_fin + +;move printname to print buffer, checking for backslashes and delimiters '|' +a2p_xlat: + push bp ;save callers bp + push cx ;save length + push es + push di ;save real buffer address + push ds + push si ;save string address + sub sp,src_str ;allocate local storage + mov bp,sp + + mov [bp].src_start,si ;save start location of source string + mov [bp].dest_start,di ;save print buffer start + GET_REAL_BUFFER_TOP dx + sub dx,pt_bfend+20 + mov [bp].dest_top,dx ;save print buffer end + + mov ax,ss + mov ds,ax + mov es,ax ;setup for c call + mov ax,512 + push ax + c_call getmem ;allocate 512 bytes of storage + add sp,2 ;dump arg from stack + cmp ax,0 ;allocation successful? + jne a2p_write ; no, go write the buffer + mov [bp].stlen,-1 ;indicate error + jmp a2p_fin2 ; and exit +a2p_write: + mov [bp].heap_top,510 ;note top of heap buffer + mov word ptr [bp].heap_str,ax ;save heap buffer address + mov word ptr [bp].heap_str+2,es + mov di,ax ;es:di = buffer + mov byte ptr es:[di],'|' ;start buffer with escape char + inc di ;di = address within buffer + mov dx,1 ;dx = # chars written + lds si,[bp].src_str ;ds:si addresses the string + mov cx,[bp].stlen ;cx = char count + xor bx,bx ;bh = strangeness + cmp cx,0 ;char count zero? + jne b2p_init ; no, jump + or bh,080h ; yes, mark as strange + jmp b2p_post ; and skip loop +b2p_init: +;dx = #chars written, di=heap buffer offset, si=string offset, cx=char count +b2plp: + cmp dx,[bp].dest_top ;room left in buffer? + jg a2p_err ; no, return error status + + lodsb ;fetch char from printname + cmp al,'\' ;is char escape char? + je escit ; yes, jump + cmp al,'|' ;is char delimiter? + jne storit ; no, just go store it +escit: + mov byte ptr es:[di],'\' ;write escape char to buffer + inc di ;bump print buffer ptr + inc dx ;bump # chars written +storit: + stosb ;write char to buffer + inc dx ;bump # chars written + + test bh,80h ;do we already know that atom's strange? + jnz skptest ; yes, skip following tests +;if lowercase letters or comma, semi-colon, etc. encountered, then it contains +;"strange" characters and must be delimited by '|' + push si ;tempsave pname offset + mov bl,al ;save copy of char in bl + lea si,hicases ;si => table of upper cases + xchg bx,si + mov ah,al ;save char + xlat ss:hicases ;fetch upper-case equivalent + xchg bx,si + cmp ah,al ;are chars different? + jne mrkstrng ; yes, indicate strangeness + mov si,offset stranges ;si => strange-character string +strnglp: lods byte ptr ss:[si] ;fetch strange char + or al,al ;finished searching for strange chars? + jz notstrng ; yes, exit loop + cmp ah,al ;Do we have a strange char? + jne strnglp ; no, try next +mrkstrng: or bh,80h ; yes, mark strange bit +notstrng: + pop si ;restore pname offset +skptest: + cmp di,[bp].heap_top ;heap buffer full? + jl a2p_cont ; no, continue + push cx ;save loop count + mov word ptr [bp].src_str,si ;update string pointer + sub di,word ptr [bp].heap_str ;calc number chars written + mov cx,di ; and save in cx + lds si,[bp].heap_str ;ds:si = heap buffer + les di,[bp].dest_str ;es:di = real mode buffer + MOVE_TO_REAL_BUF autoinc ;move string to print buffer + add word ptr [bp].dest_str,di ;update next location in real buffer + pop cx ;restore count + lds si,[bp].src_str ;ds:si = pointer into string + les di,[bp].heap_str ;es:di = heap allocated string ptr +a2p_cont: + loop b2plp ;look at next char in printname + +; bh= strangeness, dx= #chars printed, di= end of printname +; write delimeter to heap allocated string, then copy to print buffer +b2p_post: + mov al,'|' ;follow with escape char + stosb ;write to heap buffer + inc dx ;bump character count + + sub di,word ptr [bp].heap_str ;calc number chars written + mov cx,di ; and save in cx + lds si,[bp].heap_str ;ds:si = heap buffer + les di,[bp].dest_str ;es:di = real mode buffer + MOVE_TO_REAL_BUF autoinc ;move string to print buffer + mov [bp].stlen,dx ;save actual # chars written + mov ds,word ptr [bp].src_str+2 + mov si,[bp].src_start ;ds:si => start of source string + + test bh,80h ;do we already know atom's strange? + jnz a2p_fin ; yes, jump +; Check for ., #macro, or numeric confusion + cmp dx,3 ;a single char? (remember delimiters) + jne a2p_sharp ; no, jump + mov al,byte ptr ds:[si] ;get first byte of symbol + cmp al,'.' ;do we have a period - "." ? + je a2p_fin ; yes, delimits necessary +a2p_sharp: + cmp al,'#' ;macro designator? + jne a2p_num ; no, jump + cmp dx,3 ;a single sharp? (remember delimiters) + je a2p_fin ; yes, delimits necessary + cmp [bp].spg,SPECSYM*2 ;special symbol + je a2p_nodelim ; yes, no delimeters required + jne a2p_fin ; no, delimits necessary +a2p_num: + mov ax,10 ;check for number + push ax ;base 10 + push si ;ds:si => printname + call scannum ;check for number + add sp,4 ;dump args from stack + test ax,ax ;is it a number? + jnz a2p_fin ; yes, jump +a2p_nodelim: +;although symbol being witten via "write", there are no stranges chars, +;or anything, so it can be written without delimiters. + inc [bp].dest_start ;position past initial delimiter + sub [bp].stlen,2 ;exclude delimeters from length +a2p_fin: + mov ax,ss + mov ds,ax ;set up data segment + mov es,ax ; and extra segment + mov bx,512 ;length of heap buffer + pushm + C_call rlsmem, ;release character buffer + add sp,4 ;dump args off stack +a2p_fin2: + mov es,word ptr [bp].dest_str+2 + mov di,[bp].dest_start ;es:di => real buffer start + mov cx,[bp].stlen ;cx = number characters written + + lds si,[bp].src_str ;restore ds:si + add sp,call_bp ;dump args off stack + pop bp ;restore base pointer + ret + +atm2pbuf endp + +;****************************************************************************** +;STR2PBUF - Move string to printbuffer +; +; Description: +; The print buffer is in real mode, the string is moved into the print +; buffer (possibly surrounded by quotes '"' and containing escape +; characters. +; +; Upon Entry: +; cx = length of string +; ds:si => string +; es:di => print buffer +; +; Upon Exit: +; cx = number of bytes written to print buffer +; es:di => print buffer +; +;****************************************************************************** + + public str2pbuf +str2pbuf proc near + BUFFER_IS_BUFFER ;real mode buffer treated as such + + cmp ss:display,0 ;display escape chars? + jne s2p_xlat ; yes, jump +;move string to print buffer + MOVE_TO_REAL_BUF ;move string to print buffer + ret ;and return to caller + +;move string to print buffer, inserting double quotes and escape chars +s2p_xlat: + push bp ;save callers bp + push cx ;save length + push es + push di ;save real buffer address + push ds + push si ;save string address + sub sp,src_str ;allocate local storage + mov bp,sp + + mov [bp].dest_start,di ;save buffer start + GET_REAL_BUFFER_TOP dx + sub dx,pt_bfend+20 + mov [bp].dest_top,dx ;save buffer end + + mov ax,ss + mov ds,ax + mov es,ax ;setup for c call + mov ax,512 + push ax + c_call getmem ;allocate 512 bytes of storage + add sp,2 ;dump arg from stack + cmp ax,0 ;allocation successful? + jne s2p_write ; no, go write the buffer + mov cx,-1 ;indicate error + jmp s2p_fin2 ; and exit +s2p_write: + mov [bp].heap_top,510 ;note top of heap buffer + mov word ptr [bp].heap_str,ax ;save heap buffer address + mov word ptr [bp].heap_str+2,es + mov di,ax ;es:di = buffer + mov byte ptr es:[di],'"' ;start buffer with escape char + inc di ;di = address within buffer + mov dx,1 ;dx = number chars written + + mov cx,[bp].stlen + jcxz s2p_done ;jump if null string + + lds si,[bp].src_str ;ds:si addresses the string +;dx = #chars written, es:di=heap buffer offset, ds:si=string offset +s2p_loop: + cmp dx,[bp].dest_top ;room left in buffer? + jg s2p_err ; no, return error status + + lodsb ;fetch char from string + cmp al,'\' ;Is char escape char? + je s2p_esc ; yes, jump + cmp al,'"' ;Is char double quote? + jne s2p_stor ; no, just go store it +s2p_esc: + mov ah,al + mov al,'\' + stosb ;store escape character + inc dx ;bump # chars written + xchg al,ah +s2p_stor: + stosb ;store escape character + inc dx ;bump # chars written + cmp di,[bp].heap_top ;heap buffer full? + jl s2p_cont ; no, continue + push cx ;save loop count + mov word ptr [bp].src_str,si ;update string pointer + sub di,word ptr [bp].heap_str ;calc number chars written + mov cx,di ; and save in cx + lds si,[bp].heap_str ;ds:si = heap buffer + les di,[bp].dest_str ;es:di = real mode buffer + MOVE_TO_REAL_BUF autoinc ;move string to print buffer + add word ptr [bp].dest_str,di ;update next location in real buffer + pop cx ;restore count + lds si,[bp].src_str ;ds:si = pointer into string + les di,[bp].heap_str ;es:di = heap allocated string ptr +s2p_cont: + loop s2p_loop ;look at next char in printname +s2p_done: + mov al,'"' ;follow with escape char + stosb + inc dx + + sub di,word ptr [bp].heap_str ;calc number chars written + mov cx,di ; and save in cx + lds si,[bp].heap_str ;ds:si = heap buffer + les di,[bp].dest_str ;es:di = real mode buffer + MOVE_TO_REAL_BUF autoinc ;move string to print buffer + mov cx,dx ;cx = actual # chars written + jmp s2p_fin ;finished +s2p_err: + mov cx,-1 ;indicate error +s2p_fin: + push cx ;save length around call + mov bx,512 ;length of heap buffer + pushm + C_call rlsmem,,restore_es ;release character buffer + add sp,4 ;dump args off stack + pop cx +s2p_fin2: + lds si,[bp].src_str ;restore ds:si + mov es,word ptr [bp].dest_str+2 + mov di,[bp].dest_start ;es:di => real buffer start + add sp,call_bp ;dump args off stack + pop bp ;restore base pointer + ret ;return +str2pbuf endp + +prog ends + end + + \ No newline at end of file diff --git a/prosread.asm b/prosread.asm new file mode 100644 index 0000000..9954d4a --- /dev/null +++ b/prosread.asm @@ -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 + 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 + 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 + 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 + 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 + 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 + 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 + 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 + 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 + 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 ; + 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 + 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 + 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 + C_call intern,,Load_ES ; intern the symbol + mov SP,BP + lea BX,nil_reg + mov DI,main_reg + pushm + call cons ; encase in a list + mov SP,BP + jmp read_bye +; +read_nor: pushm + C_call intern,,Load_ES ; intern the symbol + mov SP,BP + lea BX,nil_reg + mov DI,main_reg + pushm + 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 + 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 + 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 + 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 + + \ No newline at end of file diff --git a/prowin.asm b/prowin.asm new file mode 100644 index 0000000..f7a26bb --- /dev/null +++ b/prowin.asm @@ -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 + 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 + C_call alloc_bl,,Load_ES ; allocate block for window object + pop BX + mov DI,[BX].C_disp ; get displacement + save + mov BX,[BX].C_page ; get page numbe of window object + LoadPage ES,BX ; get page address + shr BX,1 + pushm + call zero_blk ; zero window object + restore + 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 ; 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 ; save registers + save + mov CX,1 + pushm + 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 + 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 + 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 + 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 + add AX,offset reg0 ; compute address of register + xor BX,BX + pushm + save + 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 + 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 + mov CX,STRTYPE ; string type + pushm + C_call alloc_bl,,Load_ES ; alloc_block + mov SP,BP + pushm + restore + 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 ; 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 + xor CX,CX + pushm + C_call get_port,,Load_ES ; get the port object + mov SP,BP + restore ; 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 + call adj4bord ; adjust window region +rest_10: pushm + restore + 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 + 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 + 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 + 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 + 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 + + \ No newline at end of file diff --git a/realio.asm b/realio.asm new file mode 100644 index 0000000..21add80 --- /dev/null +++ b/realio.asm @@ -0,0 +1,1903 @@ +; =====> REALIO.ASM +;***************************************************** +;* TIPC Scheme Runtime Support * +;* Real Mode I/O Routines * +;* * +;* (C) Copyright 1985 by Texas * +;* Instruments Incorporated. * +;* All rights reserved. * +;* * +;* Date Written: November 1987 (tc) * +;* Last Modification: * +;***************************************************** + include schemed.equ ;for port defs + include screen.equ + .286c +; +; Local equates +; + +RETURN equ 0Dh ; Carriage Return Character +LINEFEED equ 0Ah ; Line Feed Character +DOS equ 021h ; Dos function request +WRITEFILE equ 040h ; Write Fiel function request +DISK_FULL equ -1 ; Disk full error designator + +TIPC equ 1 ; Designates machine type as TIPC + +TI_CRT equ 049h +IBM_CRT equ 010h + +; +; Segment Definitions +; + +PGROUP group PROG +DGROUP group DATA + +; This stack is used for the standard XLI interface. However, a different +; stack (i.e. PCS's) is used during calls to a graphics driver. +STACK segment word stack 'STACK' +stackstart = $ + dw 16 dup (?) +stacksize = $ - stackstart +STACK ends + +; +; Data definitions +; +DATA segment byte public 'DATA' + assume DS:DGROUP +datastart = $ + +callers_ds dw ? +callers_es dw ? + +;----------------------------------------------------------------------------- +; Type/Monitor info +;----------------------------------------------------------------------------- +PC_MAKE dw 0 +VID_MODE dw 3 +MAX_ROWS db DEFAULT_NUM_ROWS +MAX_COLS db DEFAULT_NUM_COLS +CHAR_HGT dw 8 + +;----------------------------------------------------------------------------- +; Jump table for handler based on op_code +;----------------------------------------------------------------------------- +OP_CODE dw BELL ; 0 - Sound Bell + dw CLEAR ; 1 - Clear Screen + dw BORDER ; 2 - Draw Border + dw SAVE_SCR ; 3 - Save Screen + dw REST_SCR ; 4 - Restore Screen + dw ? ; 5 - was turn cursor on + dw ? ; 6 - was turn cursor off + dw ? ; 7 - was position cursor + dw PUTCHAR ; 8 - Put Character on screen + dw SCROLLUP ; 9 - Scroll Screen Up 1 Line + dw SCROLLDN ; 10 - Scroll Screen Dn 1 Line + dw ? ; 11 - was ega cursor emulation + dw CHGMODE ; 12 - Note Change to Video Mode + dw WSTRING ; 13 - Write string to output port + dw WBLOCK ; 14 - Write string to display +table_len equ $ - OP_CODE + +;----------------------------------------------------------------------------- +; XLI Setup +;----------------------------------------------------------------------------- +;;; ----- Equates ----- +; offsets into the PSP +term_addr equ 0Ah +fb_addr equ 5Ch +;;; ----- Data structures ----- +; file block +file_block label word + dw 4252h + dw 10011b ;flags = sysint,0,0,16-bit,near + dw offset lookup_table, seg lookup_table + dw offset parm_block, seg parm_block +; reserved area of file block + dw 100h ;sysint# (256=%graphics) + dw offset handler, seg handler ;ISR entry point + dw 0,0,0,0,0 +; parameter block +parm_block label word ;not used + dw 0 +; lookup table +lookup_table label word + db '//' ;not used +; other needed values +psp dw ? ;PSP segment address +psize dw ? ;size of program in paragraphs +xwait dw 2 dup (?) ;XLI wait address +xbye dw 2 dup (?) ;XLI bye address + +; ___ __ __ +; + -| |- _|_ | -- | __| |__ | | (extra) +map_tab db 0c5h,0b4h,0c3h,0c1h,0c2h,0c4h,0b3h,0d9h,0c0h,0bfh,0dah,0dah +map_tabx equ $ + +trns_tab db 0dah,0c2h,0c3h,0c5h,0c3h,0c2h,0c2h,0c5h,0c3h,0c5h,0c5h + db 0c2h,0bfh,0c5h,0b4h,0b4h,0c2h,0c2h,0c5h,0c5h,0b4h,0c5h + db 0c3h,0c5h,0c0h,0c1h,0c3h,0c1h,0c5h,0c1h,0c3h,0c5h,0c5h + db 0c5h,0b4h,0c1h,0d9h,0b4h,0c1h,0c5h,0c1h,0c5h,0b4h,0c5h + db 0c3h,0b4h,0c3h,0b4h,0b3h,0c5h,0c5h,0c5h,0c3h,0b4h,0c5h + db 0c2h,0c2h,0c1h,0c1h,0c5h,0c4h,0c2h,0c1h,0c5h,0c5h,0c5h + +m14_attr equ $ +;33-60 ! " # $ % & ' ( ) * + , - . / 0 1 2 3 4 5 6 7 8 9 : ; < + db 1,0,2,2,1,4,2,0,0,3,3,7,3,5,6,2,6,6,5,3,5,2,1,2,2,1,7,3 + +;61-88 = > ? @ A B C D E F G H I J K L M N O P Q R S T U V W X + db 2,6,1,2,2,0,3,0,0,0,3,1,0,4,0,0,1,1,3,0,3,0,2,0,1,3,1,1 + +;89-116 Y Z [ \ ] ^ _ ` a b c d e f g h i j k l m n o p q r s t + db 0,1,0,0,0,3,7,1,5,0,3,4,3,3,3,0,6,6,0,0,2,2,3,2,3,2,3,2 + +;117-126 u v w x y z { | } ~ + db 2,3,3,2,2,2,3,1,0,1 + +;127-191 + db 64 dup (0) + +;192-197 + db 5,2,0,0,0,4 + +;198-218 + db 20 dup (0) +;219-220 + db 2,5 + +m16_attr equ $ +;33-60 ! " # $ % & ' ( ) * + , - . / 0 1 2 3 4 5 6 7 8 9 : ; < + db 3,1,4,4,4,7,4,2,2,6,6,11,6,9,9,4,10,10,9,6,9,4,2,4,4,3,10,6 + +;61-88 = > ? @ A B C D E F G H I J K L M N O P Q R S T U V W X + db 5,10,3,4,5,2,5,2,2,2,5,2,2,8,2,2,2,2,5,2,5,2,4,2,2,5,2,2 + +;89-116 Y Z [ \ ] ^ _ ` a b c d e f g h i j k l m n o p q r s t + db 2,2,2,2,2,3,12,2,9,2,6,7,6,6,6,2,10,11,2,2,5,5,6,5,6,5,6,4 + +;117-126 u v w x y z { | } ~ + db 5,5,5,5,5,5,6,2,2,3 + db 64 dup (0) + db 7,2,0,0,0,7 + db 20 dup (0) + db 2,7 + + public m18_attr +m18_attr equ $ +;33-60 ! " # $ % & ' ( ) * + , - . / 0 1 2 3 4 5 6 7 8 9 : ; < + db 2,1,4,4,8,8,4,2,2,6,6,10,9,10,05,4,10,10,10,6,10,4,2,4,4,10,10,6 + +;61-88 = > ? @ A B C D E F G H I J K L M N O P Q R S T U V W X + db 9,06,2,4,4,2,6,2,2,2,6,2,2,8,2,2,2,2,6,2,6,2,4,2,2,6,2,2 + +;89-116 Y Z [ \ ] ^ _ ` a b c d e f g h i j k l m n o p q r s t + db 2,2,2,3,2,3,13,2,10,2,6,8,6,6,6,2,10,12,2,2,5,5,6,5,6,5,6,4 + +;117-126 u v w x y z { | } ~ + db 5,6,6,5,5,5,6,2,2,2 + db 64 dup (0) + db 10,4,0,0,0,8 + db 20 dup (0) + db 8,8 + +; +; The following jump table is used wstring to handle control characters +; written to the screen. +; +wn_handle dw wwin_default ;00 - Null character + dw wwin_default ;01 - + dw wwin_default ;02 - + dw wwin_default ;03 - + dw wwin_default ;04 - + dw wwin_default ;05 - + dw wwin_default ;06 - + dw wwin_bell ;07 - Bell + dw wwin_backspace ;08 - Backspace + dw wwin_tab ;09 - Tab + dw wwin_linefeed ;0A - Linefeed + dw wwin_default ;0B - + dw wwin_default ;0C - + dw wwin_creturn ;0C - Carriage Return + +; +; The following jump table is used by wstring to handle control characters +; written to disk. +; +ds_handle dw wfil_default ;00 - Null character + dw wfil_default ;01 - + dw wfil_default ;02 - + dw wfil_default ;03 - + dw wfil_default ;04 - + dw wfil_default ;05 - + dw wfil_default ;06 - + dw wfil_default ;07 - + dw wfil_backspace ;08 - Backspace + dw wfil_tab ;09 - Tab + dw wfil_newline ;0A - Linefeed + dw wfil_default ;0B - + dw wfil_default ;0C - + dw wfil_newline ;0D - Carriage Return + + +last_char db 0dbh + +c_col dw 0 +c_row dw 0 +c_len dw 0 +c_nrows dw 0 + +sav_di dw 0 + +datasize = $-datastart +DATA ends + + page +;----------------------------------------------------------------------------- +;----------------------------------------------------------------------------- +PROG segment byte public 'PROG' + assume CS:PGROUP,DS:DGROUP +progstart = $ + +;----------------------------------------------------------------------------- +; name HANDLER -- Interface Handler to IO routines +; +; AX will contain error indicator (-1) if error encountered +; +hand_args struc + dw ? ; callers bp + dd ? ; return address (far) +opcode dw ? ; IO operation to perform +hand_args ends + + public handler +handler proc far + mov BX,DS ; temp save caller's DS + mov AX,data + mov DS,AX ; establish local data segment + mov callers_ds,bx ; save callers data seg + mov callers_es,es ; and extra seg + mov ES,AX +; Load sub opcode + push bp + mov bp,sp + mov BX,[BP].opcode ; load operation code + pop bp + add BX,BX ; adjust for index into jump table + cmp BX,table_len ; bad op_code? + jae bad_op + +; Jump desired IO handler + call OP_CODE[BX] + jmp short hand_ret + +bad_op: mov AX,-1 + +; Return to caller +hand_ret: + push callers_ds + pop ds ; restore caller's data seg + push callers_es + pop es ; restore caller's data seg + ret ; return to caller +handler endp + + +;************************************************************************ +;* Generate a Bell Character * +;* * +;* Purpose: To generate a "bell character" (i.e., make a noise) to * +;* simulate the effect of outputting a bell character * +;* (control-G) in the output stream. * +;* * +;* Calling Sequence: zbell(); * +;* * +;* Input Parameters: None. * +;* * +;* Output Parameters: None. * +;* * +;************************************************************************ + public bell +bell proc near + cmp PC_MAKE,TIPC ; If not tipc + jne zbmbell ; then jump +zbwait: mov AH,1 ; Get speaker status + int 48h + jnz zbwait ; wait for bell to turn off + mov AH,2 ; Set speaker frequency + mov CX,1563 ; Value for 1.25MHz/800Hz (system beep) + int 48h + mov AX,000Ah ; Turn speaker on for AL*25-ms. 0Ah = .25-sec + int 48h + xor ax,ax + ret ; return to caller +; +zbmbell: mov BX,080h ; ****Copied from IBM-PC/XT BIOS listing**** + in AL,61h + push AX ; Save +beep_cycle: and AL,0FCh ; Turn off timer gate and speaker data + out 61h,AL ; output to control + mov CX,48h ; Half cycle time for TONE +here: loop here ; speaker off + or AL,2 ; Turn speaker on + out 61h,AL + mov CX,48h +here2: loop here2 + dec BX ; Decrease cycle count + jnz beep_cycle + pop AX + out 61h,AL + xor ax,ax + ret +bell endp + +;************************************************************************ +;* Clear a Window * +;************************************************************************ +cl_args struc + dw ? ; caller's BP + dw ? ; return address + dd ? ; caller's return address +cl_op dw ? ; clear window op code +cl_row dw ? ; upper left hand corner row number +cl_col dw ? ; upper left hand corner column number +cl_nrows dw ? ; number of rows +cl_len dw ? ; line length (number of characters) +cl_attrib dw ? ; character attributes +cl_args ends + + public clear +clear proc near + push BP ; save caller's BP + mov BP,SP +; Put cursor at beginning of next row +c_loop: mov DL,byte ptr [BP].cl_row ; load current row number + mov DH,byte ptr [BP].cl_col ; load starting column number + xor BH,BH ; page number (0 if in graphics mode) + mov AH,02H ; load "put cursor" code + call crt_dsr ; position the cursor +; Write line of blanks at current cursor position + mov AX,0920h ; load write char/attr code + blank (= 20h) + xor BH,BH ; (for IBM-PC BH=display page #) + mov BL,byte ptr [BP].cl_attrib ; load attribute flag + + cmp vid_mode,14 ; IBM EGA modes? + jl c_01 + cmp BL,87h ; attribute is rv white? + jne c_22 + mov AX,09dbh ; use the block character not the blank + and BL,7fh ; strip off the xor bit + +c_01: mov CX,[BP].cl_len ; load number of times to write the blank + call crt_dsr ; perform the write +; Increment row number, decrement row count, test, loop + inc [BP].cl_row ; increment row number + dec [BP].cl_nrows ; decrement row count + jg c_loop ; if more rows, loop (jump) +; Return to caller +c_end: pop BP ; restore caller's BP + xor ax,ax ; return status + ret ; return + + ; clear out the line by writing directly to the graphics planes +c_22: + mov AX,[BP].cl_nrows + mov c_nrows,ax + mov AX,[BP].cl_row ; set AX to the row + mov c_row,AX + mov AX,[BP].cl_col ; add in the starting column + mov c_col,AX + mov AX,[BP].cl_len ; number of columns to blank + mov c_len,AX + call z_ega ; restore counter + + jmp c_end ; return + +clear endp + +;************************************************************************ +;* Draw Border * +;************************************************************************ +b_args struc + dw ? ; caller's BP + dw ? ; return address + dd ? ; caller's return address +b_opcode dw ? ; border opcode +b_line dw ? ; upper left corner line number +b_col dw ? ; upper left corner column number +b_nlines dw ? ; number of lines +b_ncols dw ? ; number of columns +b_battr dw ? ; border attributes +b_label dw ? ; pointer to label text +b_args ends + + public border +border proc near +;;; int 3 + push BP ; save caller's BP + mov BP,SP + +; output corners + mov BL,byte ptr [BP].b_battr ; load attribute bits + mov DH,byte ptr [BP].b_col ; load left column number + mov DL,byte ptr [BP].b_line ; load left line number + dec DL + dec DH + mov AL,0DAh ; load upper left corner character + call zcorner + inc DH + add DH,byte ptr [BP].b_ncols + mov AL,0BFh ; load upper right corner character + call zcorner + inc DL + add DL,byte ptr [BP].b_nlines + mov AL,0D9h ; load lower right corner character + call zcorner + dec DH + sub DH,byte ptr [BP].b_ncols + mov AL,0C0h ; load lower left corner character + call zcorner + +; output sides + mov DH,byte ptr [BP].b_col ; reload upper left column number + mov DL,byte ptr [BP].b_line ; and line number + dec DH ; decrement column number + mov CX,[BP].b_nlines + call zside ; draw the left hand border + mov DH,byte ptr [BP].b_col ; reload upper left column number + mov DL,byte ptr [BP].b_line ; and line number + add DH,byte ptr [BP].b_ncols ; add in line length + mov CX,[BP].b_nlines + call zside ; draw the right hand border + +; Output the top of the border + mov DL,byte ptr [BP].b_line ; load upper left row number + dec DL + jl z_no_top ; if row negative, skip write + mov DH,byte ptr [BP].b_col ; load upper left column number + mov CX,[BP].b_ncols + call ztop +; Put the label in the top left corner of the border, if it'll fit + mov BX,[BP].b_label ; get segment of label + cmp BX,0 + je z_no_top ; jump, if NULL pointer + mov ES,BX + mov BX,0 ; ES:BX => label + mov DX,[BP].b_ncols ; load window width + xor CX,CX ; zero the character counter +b_loop: cmp byte ptr ES:[BX],0 ; end of string? + je b_eos ; if end of string, jump + inc CX ; increment the character count + inc BX ; increment the character string pointer + cmp CX,DX ; compare to window width + jl b_loop ; if label still shorter than window, loop +b_eos: jcxz z_no_top ; if no label, jump + push CX ; save label length +; Write the label + mov DL,byte ptr [BP].b_line ; load upper left row number + mov DH,byte ptr [BP].b_col ; load upper left column number + dec DL ; decrement row number + xor BH,BH ; IBMism (page 0 for text-mode) + mov AH,02h ; load "put cursor" code + call CRT_DSR ; put cursor in upper left corner of border + pop CX ; restore label's character count + cmp PC_MAKE,TIPC + jne ibm_cblk + mov AH,011h ; load "write block of characters" code + mov DX,ES ; load segment address + mov BX,0 ; load label offset + int TI_CRT ; write the label + jmp short z_no_top +; +ibm_cblk: mov AL,byte ptr [BP].b_col + add AL,CL + cmp AL,MAX_COLS + jle b_sml ; jump if label length is OK + sub AL,MAX_COLS + sub CL,AL ; force label to remain within 80-col screen +b_sml: mov DI,0 ; load label offset +lbl_loop: mov AH,0Eh ; Write ASCII Teletype + mov AL,byte ptr ES:[DI] + mov BL,byte ptr [BP].b_battr ; load attribute bits just in case + xor BH,BH ; page # for alpha mode + push CX + push DI + int IBM_CRT + pop DI + pop CX + inc DI + loop lbl_loop ; DECrement CX and jump if != 0 +; Output the bottom of the border +z_no_top: + mov dx,ds + mov es,dx + mov BL,byte ptr [BP].b_battr ; load attribute bits + mov DL,byte ptr [BP].b_line + add DL,byte ptr [BP].b_nlines + mov DH,byte ptr [BP].b_col ; load upper left column number + mov CX,[BP].b_ncols + call ztop + +; return to caller + pop BP ; restore caller's BP + xor ax,ax + ret ; return +border endp + +;************************************************************************ +;* Local Support: Draw a single character at cursor position * +;* * +;* Input Registers: AL - the character to be output * +;* BL - the character attributes for the write * +;* DH - column * +;* DL - row * +;* * +;* Registers Modified: AX,CX,SI,DI * +;************************************************************************ +zcorner proc near ; draw a single corner character + cmp DH,MAX_COLS + jae zcornret + cmp DL,MAX_ROWS + jae zcornret + push DX ; save cursor coordinates + push AX ; save character to be output + xor BH,BH ; page number (=0 for graphics mode also) + mov AH,02h ; load "put cursor" code + call CRT_DSR ; position the cursor +; read the character in this screen position +; ** This is tricky 'cause DH/DL are correct but +; ** will be swapped back (to incorrect) by CRT_DSR proc +; ** if using an IBM!!! + cmp PC_MAKE,TIPC + je no_swap + xchg DH,DL + xor BH,BH ; IBM display page +no_swap: mov AH,08h + call CRT_DSR +; see if it's one of the borderline characters + call map_char + mov SI,AX + pop AX ; recover character to be output + cmp SI,0 + jl zcornput +; map corner to border character + call map_char + mov DL,map_tabx-map_tab-1 + mul DL + add SI,AX + mov AL,trns_tab+[SI] +; output the corner character +zcornput: mov AH,09h ; load "write character/attribute" code + mov CX,1 ; number of characters = 1 + xor BH,BH ; Display page for IBM text mode (=0) + call CRT_DSR ; write it to the screen at cursor position + pop DX ; restore cursor coordinates +zcornret: ret ; return +zcorner endp + +;************************************************************************ +;* Local Support: Draw a border sides * +;* * +;* Input Registers: DH - column * +;* DL - row * +;* CX - number of rows * +;* * +;* Registers Modified: AX,CX,DL * +;************************************************************************ +zside proc near + cmp DH,MAX_COLS ; is column within the CRT's boundaries? + jae zsideret ; if not, jump +zside_lp: mov AL,0B3h ; load "|" border character + push CX ; save line count + push DX ; save next cursor position + call zcorner ; output the border character + pop DX ; restore current cursor position + pop CX ; restore line counter + inc DL ; increment the row number + loop zside_lp ; loop until side is drawn +zsideret: ret +zside endp + +;************************************************************************ +;* Local Support: Draw a border - Top or Bottom * +;* * +;* Input Registers: DH - column * +;* DL - row * +;* CX - number of columns * +;* * +;* Registers Modified: AX,CX * +;************************************************************************ +ztop proc near + cmp DL,MAX_ROWS ; is row within the CRT's boundaries? + jae ztopret ; if not, jump +ztop_lp: mov AL,0C4h ; load "-" border character + push CX ; save line count + push DX ; save next cursor position + call zcorner ; output the border character + pop DX ; restore current cursor position + pop CX ; restore line counter + inc DH ; increment the column number + loop ztop_lp ; loop until top/bottom is drawn +ztopret: ret +ztop endp + +;************************************************************************ +;* Local Support: return character mapping * +;* * +;* Input Registers: AL = character * +;* * +;* Registers Modified: CX,DI * +;************************************************************************ +map_char proc near + mov CX,map_tabx-map_tab + mov DI,offset map_tab +repne scasb + mov AX,CX + dec AX + ret +map_char endp + +;************************************************************************ +;* Save Screen Contents * +;* * +;* Purpose: To save a rectangular region of the CRT in a string data * +;* object. * +;* * +;* Calling Sequence: save_scr(str_reg, ul_row, ul_col, n_rows, ncols) * +;* where str_reg - pointer to string data object * +;* which is to receive the screen * +;* contents * +;* ul_row - row number of the upper left * +;* corner of the region to be * +;* saved * +;* ul_col - column number of the upper left * +;* corner of the region to be * +;* saved * +;* n_rows - number of rows in the region to * +;* be saved * +;* n_cols - number of columns in the region * +;* to be saved * +;************************************************************************ +sv_args struc + dw ? ; caller's BP + dw ? ; caller's ES + dw ? ; return address + dd ? ; caller's return address +sv_op dw ? ; save screen opcode +sv_str dw ? ; address of register pointing to string +sv_ulrow dw ? ; upper left hand corner's row number +sv_ulcol dw ? ; upper left hand corner's column number +sv_nrow dw ? ; number of rows +sv_ncol dw ? ; number of columns +sv_args ends + + public save_scr +save_scr proc near +;;; int 3 + push ES + push BP ; save the caller's BP register + mov BP,SP ; and establish local addressability +; create a pointer to the string object +;;; mov BX,[BP].sv_str ; load address of register +;;; mov DI,[BX].C_disp ; load the string +;;; mov BX,[BX].C_page ; pointer +;;; %LoadPage ES,BX ; load string page's paragraph address +;;; mov ES,pagetabl+[BX] ; load string page's paragraph address +;;; add DI,BLK_OVHD ; advance pointer past string header + + mov ES,[BP].sv_str + xor DI,DI ;ES:DI => string + +; store number of rows and columns into the first two bytes of the string + mov AL,byte ptr [BP].sv_nrow + stosb + mov AL,byte ptr [BP].sv_ncol + stosb +; adjust number of lines/columns for test conditions + mov AX,[BP].sv_ulrow + add [BP].sv_nrow,AX + mov AX,[BP].sv_ulcol + add [BP].sv_ncol,AX +; loop until all rows processed + mov DL,byte ptr [BP].sv_ulrow +rw_loop: mov DH,byte ptr [BP].sv_ulcol +; position cursor +cl_loop: push DX ; save current position + mov AH,02h ; load "put cursor" function id + xor BH,BH ; IBMism (page number for cursor) + call crt_dsr ; position the cursor +; read character/attributes at current screen position + mov AH,08h ; load "read char/attribute" function id + xor BH,BH ; IBMism (display page #) + call crt_dsr ; read said +;******* + cmp vid_mode,14 + jl sav_01 ; not graphics modes + cmp AL,0 ; don't bother with attributes if nul + je sav_01 +; cmp AL,07fh ; is it above the first 128 characters ? +; jno sav_00 ; no + cmp AL,0dah + jbe sav_00 +; test AL,010h ; look for D0-DF +; je sav_00 + xor AL,AL ; set to nul + jmp sav_01 +sav_00: call graph_attr ; mode 14 and 16 attribute function +;****** +sav_01: stosw ; store char/attr into output string +; increment column number, test, branch + pop DX + inc DH + cmp DH,byte ptr [BP].sv_ncol + jl cl_loop +; increment row number, test, branch + inc DL + cmp DL,byte ptr [BP].sv_nrow + jl rw_loop + +; return to caller + pop BP + pop ES + xor ax,ax + ret ; return to caller +save_scr endp + +;************************************************************************ +;* Restore Screen Contents * +;* * +;* Purpose: To restore a rectangular region of the CRT from a string * +;* data object. * +;* * +;* Calling Sequence: rest_scr(str_reg, ul_row, ul_col) * +;* where str_reg - pointer to string data object * +;* which contains the screen * +;* contents * +;* ul_row - row number of the upper left * +;* corner of the region to be * +;* restored * +;* ul_col - column number of the upper left * +;* corner of the region to be * +;* restored * +;************************************************************************ +rs_args struc +rs_nrow dw ? ; number of rows in saved data +rs_ncol dw ? ; number of columns in saved data +rs_BP dw ? ; caller's BP + dw ? ; caller's ES + dw ? ; return address + dd ? ; callers return address +rs_op dw ? ; restore screen opcode +rs_str dw ? ; segment address of string +rs_ulrow dw ? ; upper left hand corner's row number +rs_ulcol dw ? ; upper left hand corner's column number +rs_mrow dw ? ; number of rows in new window +rs_mcol dw ? ; number of columns in new window +rs_args ends + + public rest_scr +rest_scr proc near + int 3 + push ES + push BP ; save the caller's BP register + sub SP,offset rs_BP + mov BP,SP ; and establish local addressability + +; address the string + + mov ES,[BP].rs_str + xor SI,SI ; ES:SI => string + +; get number of rows and columns from screen object + xor AH,AH + lods byte ptr ES:[SI] + add AX,[BP].rs_ulrow + mov [BP].rs_nrow,AX + xor AH,AH + lods byte ptr ES:[SI] + add AX,[BP].rs_ulcol + mov [BP].rs_ncol,AX +; adjust number of lines/columns for test conditions + mov AX,[BP].rs_ulrow + add [BP].rs_mrow,AX + mov AX,[BP].rs_ulcol + add [BP].rs_mcol,AX +; loop until all rows processed + mov DL,byte ptr [BP].rs_ulrow +xw_loop: mov DH,byte ptr [BP].rs_ulcol +; position cursor +xl_loop: cmp DH,byte ptr [BP].rs_mcol ; column too long for new window? + jge x_long ; if too long, jump + push DX ; save current position + mov AH,02h ; load "put cursor" function id + xor BH,BH ; IBMism (page number/0 in graphic mode) + call crt_dsr ; position the cursor +; read character/attributes at current screen position + lods word ptr ES:[SI] ; fetch the character and attribute + +;;;;;;;; cmp AL,20h +;;;;;;;; je x_sp ; if a space skip + + mov BL,AH ; and copy attribute to BL + mov AH,09h ; load "write char/attribute" function id + xor BH,BH ; IBMism (page number) + mov CX,1 ; character count = 1 + call crt_dsr ; read said +; increment column number, test, branch +x_sp: pop DX ; recover the row/column coordinates +x_more: inc DH ; increment the column number + cmp DH,byte ptr [BP].rs_ncol ; more characters in this row? + jl xl_loop ; if so, jump +; increment row number, test, branch + inc DL ; increment the row number + cmp DL,byte ptr [BP].rs_mrow ; check against new window boundary + jge rs_fin ; if all rows filled, jump + cmp DL,byte ptr [BP].rs_nrow ; check against saved data + jl xw_loop ; if more lines, jump + +; return to caller +rs_fin: add SP,offset rs_BP ; deallocate local storage + pop BP ; restore the caller's BP register + pop ES ; restore the caller's ES register + xor ax,ax + ret ; return to caller +; +x_long: inc SI ; increment index into saved screen + inc SI ; buffer + jmp short x_more ; continue processing row +rest_scr endp + + +;************************************************************************ +;* Output Character To Window * +;************************************************************************ +pch_args struc + dw ? ; caller's BP + dw ? ; return address + dd ? ; caller's return address +p_op dw ? ; putchar opcode +p_line dw ? ; cursor position - line number +p_col dw ? ; cursor position - column number +p_char dw ? ; character to write +p_attr dw ? ; character's attributes +pch_args ends + + public putchar +putchar proc near + push BP ; save caller's BP + mov BP,SP +; position cursor for write + mov DL,byte ptr [BP].p_line ; load line number + mov DH,byte ptr [BP].p_col ; load column number + xor BH,BH ; IBMism + mov AH,02h ; load "put cursor" code + call crt_dsr ; positio the cursor + + mov BL,byte ptr [BP].p_attr ; load its attributes + cmp vid_mode,14 ; only attribute for EGA modes is a + jl pchar_1 ; simulated reverse video + + mov BH,BL ; save the attribute + and BH,80h ; reverse video? + jz pchar_1 ; zero indicates bit 8 not set + +pchar_2: and BL,7fh ; strip off high bit + mov CX,1 ; character count + xor BH,BH ; video page number + mov AL,0dbh ; block character + mov AH,09h + call crt_dsr + or BL,80h ; set xor bit +; write the characters with attributes +pchar_1: mov AL,byte ptr [BP].p_char ; load the character + xor BH,BH ; IBMism + mov CX,1 ; repeat count = 1 + mov AH,09h ; load write char/attribute code + call crt_dsr +; return to caller + xor ax,ax + pop BP + ret +putchar endp + +;************************************************************************ +;* Scroll Window Up one line * +;************************************************************************ +su_args struc + dw ? ; caller's BP + dw ? ; return address + dd ? ; caller's return address +su_op dw ? ; scroll opcode +su_line dw ? ; upper left hand corner line number +su_col dw ? ; upper left hand corner column number +su_nline dw ? ; number of lines +su_ncols dw ? ; number of columns +su_attr dw ? ; text attributes (used for blanking) +su_args ends + + public scrollup +scrollup proc near + push BP ; save caller's BP + mov BP,SP +; scroll window's text up one line + mov CL,byte ptr [BP].su_nline ; load number of lines + dec CL ; decrease number of lines by one + jz blank1 ; Jump if scrolling 1-line and just blank it + mov CH,byte ptr [BP].su_ncols ; load number of columns + mov DL,byte ptr [BP].su_line ; load upper left line number + mov DH,byte ptr [BP].su_col ; load upper left column number + mov AX,0601h ; load "scroll text" code with no blanking + cmp DGROUP:PC_MAKE,TIPC + je ti_scrl + cmp vid_mode,4 ; Are we in graphics mode? + jl txt_mod ; If we are then fix blank fill attributes + cmp vid_mode,7 ; so that the bar characters don't show up + je txt_mod + xor BH,BH ; zero attribute for fill blanks + jmp short rite_atr +txt_mod: mov BH,byte ptr [BP].su_attr ; Blanked lines' attribute txt mode +rite_atr: 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 z_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_scrl: mov BX,DX ; copy destination coordinates + inc DL ; compute source by incrementing line number + int TI_CRT ; perform block move +; paint the last line of the window with blank of proper attributes +blank1: mov DH,byte ptr [BP].su_col ; load starting column number + mov DL,byte ptr [BP].su_line ; load upper line number + add DL,byte ptr [BP].su_nline ; add the number of lines and + dec DL ; subtract offf one + mov AH,02h ; load "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].su_attr ; load attribute bit setting + + cmp vid_mode,14 ; ega mode? + jl z_scr01 + mov BH,BL + and BH,80h + cmp BH,80h ; reverse video? + jne z_scr01 + mov AX,09dbh ; change for block character + and BL,7fh ; strip off xor bit +z_scr01: xor BH,BH ; IBMism + mov CX,[BP].su_ncols ; load line length + call crt_dsr ; write a line of blanks +; return to caller +z_quit: pop BP + xor ax,ax + ret +scrollup endp + + +;************************************************************************ +;* Scroll Window Down one line * +;************************************************************************ +sd_args struc + dw ? ; caller's BP + dw ? ; return address + dd ? ; caller's return address +sd_op dw ? ; op code +sd_line dw ? ; upper left hand corner line number +sd_col dw ? ; upper left hand corner column number +sd_nline dw ? ; number of lines +sd_ncols dw ? ; number of columns +sd_attr dw ? ; text attributes (used for blanking) +sd_args ends + +scrolldn proc near + push BP ; save caller's BP + mov BP,SP +; scroll window's text down one line + mov CL,byte ptr [BP].sd_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].sd_ncols ; load number of columns + mov DL,byte ptr [BP].sd_line ; load upper left line number + mov DH,byte ptr [BP].sd_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].sd_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].sd_col ; load starting column number + mov DL,byte ptr [BP].sd_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].sd_attr ; load attribute bit setting + xor BH,BH ; IBMism + mov CX,[BP].sd_ncols ; load line length + call crt_dsr ; write a line of blanks +; return to caller +quit: pop BP ; restore caller's BP + xor ax,ax + ret +scrolldn endp + +;**************************************************************************** +;* * +;* Change Video Mode * +;* * +;* Purpose: to note changes to video mode. * +;* * +;**************************************************************************** +chgvmode struc + dw ? ; caller's BP + dw ? ; return address + dd ? ; caller's return address +chg_op dw ? ; op code +chg_chgt dw ? ; new character height +chg_mode dw ? ; new video mode +chg_rows dw ? ; new max rows for screen +chgvmode ends + + public chgmode +chgmode proc near + int 3 + push bp + mov bp,sp + mov ax,[bp].chg_mode + mov VID_MODE,ax + mov ax,[bp].chg_chgt + mov CHAR_HGT,ax + mov ax,[bp].chg_rows + mov MAX_ROWS,al + pop bp + xor ax,ax + ret +chgmode endp + + + +;**************************************************************************** +;* * +;* WRITE BLOCK OF CHARACTERS * +;* * +;* Purpose: Write a character string to the display * +;* * +;**************************************************************************** +wblk_args struc + dw ? ;caller's BP + dw ? ;return address + dd ? ;caller's return address +blk_op dw ? ;op code +blk_len dw ? ;length of block to write +blk_buf db 100 dup (?) ;buffer to write +blk_txt dw ? ;text attributes +blk_cur dw ? ;cursor position +wblk_args ends + + public wblock +wblock proc near + int 3 + push bp + mov bp,sp + + mov ah,02h ;load "put cursor" code + xor bh,bh ;IBMism - page 0 for text mode + mov dx,[bp].blk_cur ;dx = cursor coordinates + call crt_dsr ;position the cursor + + mov cx,[bp].blk_len ;cx = number of characters + + cmp PC_MAKE,TIPC ;on what flavor PC are we running? + jne blk_ibm ;if an IBM, jump +; Write line to TIPC's screen + mov al,byte ptr [bp].blk_txt ;load text attributes + mov ah,010h ;load "write block w/ attr" code + mov dx,ss ;load segment address + mov bx,bp ;load buffer offset in segment + add bx,blk_buf + int TI_CRT + jmp blk_end + +; Write line to IBM's screen +blk_ibm: mov di,bp + add di,blk_buf ;load buffer offset + mov dx,[bp].blk_cur ;reverse row/column coordinates + xchg dl,dh + mov [bp].blk_cur,dx + push cx ; save + jmp short blk_imidl ;jump into middle of loop + +blk_iloop: + push cx ;save the character counter + mov dx,[bp].blk_cur ;load the previous cursor coordinates, + inc dl ;increment the column number + mov [bp].blk_cur,dx ;and save new coordinates + xor bh,bh ;page number (0 for graphics mode) IBMism + mov ah,02h ;load "put cursor" code + push di + int IBM_CRT ;position the cursor + pop di +blk_imidl: + mov ah,09h ;load "write char w/ attributes" code + mov al,byte ptr ss:[di] ;load character from buffer + mov BL,byte ptr [bp].blk_txt ;load attribute bits + xor bh,bh ;page # for alpha mode + mov cx,1 ;load repeat count = 1 + pop dx ;restore character count +; test to see if we buy anything by using a repeat count +blk_imore: + cmp dx,1 ;more characters to display? + jle blk_ibotm ;if no more characters, jump + cmp al,byte ptr ss:[di]+1 ;is next character the same as previous? + jne blk_ibotm ;if not same character, jump + inc cx ;increment the repeat count + inc di ;increment the output buffer index + inc byte ptr [bp].blk_cur ;increment the cursor position + dec dx ;decrement the character count + jmp blk_imore ;try for another +blk_ibotm: +; output the character(s) + push dx ;save the adjusted character count + push di ;save the output buffer index + int IBM_CRT ;output the char(s) + pop di ;restore the output buffer index + pop cx ;restore character counter + inc di ;increment buffer pointer + loop blk_iloop ;continue 'til all characters output + +blk_end: + pop bp ;restore stack + ret ; and return +wblock endp + +;**************************************************************************** +;* * +;* WRITE CHARACTER STRING * +;* * +;* Purpose: Write a character string to the given port object * +;* * +;**************************************************************************** +wstr_args struc + dw ? ; caller's BP + dw ? ; return address + dd ? ; caller's return address +wrt_op dw ? ; op code +;;; wrt_newl dw ? ; newline before writing +wrt_wrap dw ? ; check wrap before writing string +wrt_offs dw ? ; string offset +wrt_seg dw ? ; string segment +wrt_len dw ? ; # characters +wrt_port dw ? ; port object +wstr_args ends + + public wstring +wstring proc near + int 3 + push bp + mov bp,sp + cmp [bp].wrt_len,0 ;anything to write? + jg wst_10 ; yes, continue + jmp wst_fin +wst_10: + + cmp [bp+wrt_wrap],0 ;check wrap before writing? + je wst_15 ; no, continue + xor ax,ax ;ax = wrap indicator (0 = no) + mov bx,[bp+wrt_port].pt_ncols ;bx = line length + cmp bx,0 ;maintaining line length? + je wst_15 ; no, jump + mov cx,[bp+wrt_port].pt_ccol ;cx = current column + cmp cx,1 ;in first column already? + jle wst_15 ; yes, jump + sub bx,cx ;determine space remaining + cmp bx,[bp+wrt_len] ;room left on current line? + jge wst_15 ; yes, jump + inc ax ;set wrap indicator +wst_15: + mov [bp+wrt_wrap],ax ;update wrap indicator + mov bx,[bp+wrt_port].pt_pflgs ;get window flags + test bx,OPEN ;is port open for writing? + jz wst_esc ; no, get outa here + test bx,STRIO ;is port a string? + jnz wst_esc ; yes, return + test bx,WINDOW ;is port a window? + jnz wst_win ; yes, go to window code + jmp wst_fil ; no, go to file code +wst_esc: jmp wst_fin +;***************************************************************************** +; We have a valid window port. Write the string to the display. +;***************************************************************************** +wst_win: + les di,dword ptr [bp+wrt_offs] ;es:di => string buffer + + mov bx,[bp+wrt_port].pt_cline ;bx = current line + mov ax,[bp+wrt_port].pt_ccol ;ax = current column + mov dx,[bp+wrt_port].pt_ullin ;dx = upper left line # + cmp [bp+wrt_wrap],0 ;wrap before writing string? + je wwin_start ; no, jump + xor ax,ax ;clear current column + inc bx ;bump current line + cmp bx,[bp+wrt_port].pt_nline ;exceeded number of lines? + jl wwst_w10 ;no, skip scroll + int 3 + call scrollit ;scroll the display +wwst_w10: + push ax + push di + push es:[di] ;next character + call isspace ;determine if whitespace + pop di + or ax,ax ;is it? + pop ax + jz wwin_start ; no, jump + inc di + dec [bp+wrt_len] ;decrement string length + jnz wwin_start ;if non-zero, go + mov [bp+wrt_port].pt_cline,bx ;save current cursor line number + mov [bp+wrt_port].pt_ccol,ax ;save current cursor column number + jmp wst_fin ; else return +wwin_start: + mov cx,[bp+wrt_len] +; +; loop through the chars, writing them to the display +; +wwin_loop: + push cx + push di + + mov cl,es:[di] + cmp cl,RETURN ;if char = carriage return +;;;;;;;; je wwin_creturn ; then jump + ja wwin_default ;if not control char, jump + xor ch,ch + mov si,cx + shl si,1 ;get index into jump table + jmp [wn_handle+si] ;go to handler + +; default character handler +; +wwin_default: + cmp ax,[bp+wrt_port].pt_ncols ;are we in the last column? + jl wwin_linechk ; no, jump + test [bp+wrt_port].pt_wflgs,W_WRAP ;wrap option on? + jnz wwin_scrl ; yes, jump + inc ax ;clip - bump column + jmp wwin_100 ; continue +wwin_linechk: + cmp bx,[bp+wrt_port].pt_nline ;out of lines? + jl wwin_wchar ;no, return +wwin_scrl: + inc bx ;bump current line + xor ax,ax ;clear column + cmp bx,[bp+wrt_port].pt_nline ;exceeded number of lines? + jl wwin_wchar ; no, jump + call scrollit +wwin_wchar: + push ax ;save current column + push bx ;save current line + + cmp vid_mode,3 + jne wwin_gen + cmp pc_make,1 + je wwin_gen + + xchg ax,bx + add ax,[bp+wrt_port].pt_ullin + mov ah,80 + mul ah + add ax,bx + add ax,[bp+wrt_port].pt_ulcol + shl ax,1 + mov si,ax + mov ch,byte ptr [bp+wrt_port].pt_text + push ds + push 0B800h + pop ds + mov [si],cx + pop ds + jmp wwin_nxt +wwin_go: + jmp wwin_loop +wwin_gen: + push [bp+wrt_port].pt_text ;push text character attribute + push es:[di] ;push the character + add ax,[bp+wrt_port].pt_ulcol + push ax ;column number to console + add bx,[bp+wrt_port].pt_ullin + push bx ;line number to console + sub sp,6 + call putchar ;display character + add sp,14 ;dump args off stack +wwin_nxt: + pop bx ;restore current line + pop ax ;restore current column + inc ax ;increment current column +wwin_100: mov [bp+wrt_port].pt_cline,bx ;save current cursor line number +wwin_120: mov [bp+wrt_port].pt_ccol,ax ;save current cursor column number + pop di + inc di + pop cx + loop wwin_go +;;;; loop wwin_loop ;if more chars, loop + jmp wst_fin ; else go home + +; +; Handlers for special characters (RETURN,LINEFEED,TAB,BACKSPACE) +; + +; Carriage return character handler +wwin_creturn: + mov cl,LINEFEED ;fall thru to linefeed handler +; Line Feed character handler +wwin_linefeed: + xor ax,ax ;clear column + inc bx ;bump line number + cmp bx,[bp+wrt_port].pt_nline ;exceeded number of lines? + jl wwin_100 ; no, jump + call scrollit ; yes, scroll + jmp wwin_100 +; Backspace character handler +wwin_backspace: + dec AX ;decrement current column + cmp AX,0 ;if column now positive + jge wwin_120 ; then return + xor AX,AX ;cur_col = 0 + jmp wwin_120 ;return +; Bell character handler +wwin_bell: + push ax + push bx + call bell ;sound the alarm + pop bx + pop ax + jmp wwin_120 ;and return +; Tab character handler +wwin_tab: + mov cx,ax ;cx = current column + mov dx,8 ;dl = 8 + div dl ;ah = (cur_col % 8) + sub dl,ah + add cx,dx + mov ax,cx ;update current column + jmp wwin_120 ;and return + +;***************************************************************************** +; We have a valid file port. Write the string to the disk. +;***************************************************************************** +wst_fil: + int 3 + xor ax,ax ;clear ax for char later + les di,dword ptr [bp+wrt_offs] ;es:di => string buffer + + test [bp+wrt_port].pt_pflgs,BINARY ;binary file? + jnz wfil_start ; yes, skip newline + cmp [bp+wrt_wrap],0 ;wrap before writing string? + je wfil_start ; no, go write chars to disk + mov al,RETURN ; yes, write CR/LF to file + call write_char + xor ax,ax ;set current column to 0 + call upd_port ;update port object + mov al,LINEFEED + call write_char + xor ax,ax ;set current column to 0 + call upd_port ;update port object + push di + push es:[di] + call isspace ;determine next char whitespace + pop di + or ax,ax ;is it? + jz wfil_start ; no, jump + inc di ; + dec [bp+wrt_len] ;decrement string length + jnz wfil_start ;if non-zero, continue + jmp wst_fin ; else return +wfil_start: + mov cx,[bp+wrt_len] +; +; loop through the chars, writing them to the display +; +wfil_loop: + push cx ;save length + push di ;save index to string + + mov cl,es:[di] ;get character just written + cmp cl,RETURN ;test for control char + ja wfil_default ; if not, handle as default case + je wfil_newline ; if return, go handle + xor ch,ch ;clear high byte + mov si,cx ;move char to index reg + shl si,1 ;get index into jump table + jmp [ds_handle+si] ;go to handler + +wfil_default: + mov cx,1 ;cx = length + mov bx,[bp+wrt_port].pt_handl ;bx = handle + mov dx,di ;dx = offset + mov ax,es ;ax = segment + call diskout + mov ax,[bp+wrt_port].pt_ccol ;ax = current column + cmp ax,[bp+wrt_port].pt_ncols ;have we exceeded line length + jl wfil_10 ; no, jump + xor ax,ax ;clear current column + jmp wfil_upd ;go update port data +wfil_10: inc ax ;bump current column +wfil_upd: call upd_port + pop di ;restore string index + inc di ;and increment + pop cx ;restore length + loop wfil_loop ;loop if more +wst_fin: + xor ax,ax + pop bp + ret ;return to caller + +; +; Handlers for special characters (RETURN,LINEFEED,TAB,BACKSPACE) +; + +; Carriage return or linefeed character handler +wfil_newline: + test [bp+wrt_port].pt_pflgs,BINARY ;binary file? + jnz wfil_default ; yes, output char + mov al,RETURN ; no, output cr/lf + call write_char + xor ax,ax ;set current column to 0 + call upd_port ;update port object + mov al,LINEFEED + call write_char + xor ax,ax + jmp wfil_upd + +; backspace character handler +wfil_backspace: + test [bp+wrt_port].pt_pflgs,BINARY ;binary file? + jnz wfil_10 ;yes, output char + mov al,byte ptr es:[di] ;al = backspace char + call write_char ;write it out + mov ax,[bp+wrt_port].pt_ccol ;ax = current column + dec ax ;decrement it + cmp ax,0 + jge wfil_upd + xor ax,ax + jmp wfil_upd +; tab character handler +wfil_tab: + test [bp+wrt_port].pt_pflgs,BINARY ;binary file? + jnz wfil_10 ;yes, jump + mov al,byte ptr es:[di] ;al = tab char + call write_char ;write it out + mov ax,[bp+wrt_port].pt_ccol ;ax = current column + mov cx,ax + mov dx,8 + div dl ; ah = (cur_col % 8) + sub dl,ah + add cx,dx + mov ax,cx + jmp wfil_upd + + +;***************************************************************************** +; Utilty routines for writing characters to display or disk +;***************************************************************************** + +;UPD_PORT - update port object +; entry: ax = current column +upd_port proc near + cmp [bp+wrt_port].pt_ncols,0 ;if line length = 0 + je upd_05 ; then don't maintain column + mov [bp+wrt_port].pt_ccol,ax ;save current column +upd_05: + mov ax,[bp+wrt_port].pt_bfpos ;get current buffer position + inc ax ;bump the position + cmp ax,256 ;crossed chunk boundary? + jle upd_10 ; no, jump + sub ax,256 ;ax=excess above chunk + inc [bp+wrt_port].pt_chunk ;update chunk number +upd_10: mov [bp+wrt_port].pt_bfpos,ax ;update buffer position + ret +upd_port endp + +;WRITE_CHAR - write character to port +; entry: ax = character to write to port +write_char proc near + mov cx,1 ;length + mov bx,[bp+wrt_port].pt_handl ;handle + push ax + mov dx,sp + mov ax,ss + call diskout + pop ax + ret +write_char endp + + +;DISKOUT - output char(s) to disk +; entry: ax=segment, bx=handle, cx=buffer length, dx=offset +; exit: carry set = error, ax=status +; errors will return to the caller of wstring +diskout proc near + push ds + mov ds,ax + mov ah,WRITEFILE + int DOS ;perform disk write + pop ds + jc diskerr + cmp ax,cx ;everything written? + je diskret ; yes, return + mov ax,DISK_FULL ;note disk full error + jmp derr_ret +diskerr: + int 3 +;;; +;;; For some reason, the following doesn't work. Must be a failure by +;;; AI Architects support of Get Extended Error. In the interim, just +;;; use the return value in ax. Returning is easy, just dump local +;;; storage from the stack, pop the callers bp, and return. +;;; +;;; xor bx,bx +;;; mov AH,059h ;GET_EXTENDED_ERROR +;;; int DOS ;Extended error code in AX +derr_ret: mov sp,bp ;dump everything off stack + pop bp ;return to handler, error in ax +diskret: + ret +diskout endp + +;ISSPACE - determine if character is whitespace +; +isspace proc near + pop di + pop ax + cmp al,' ' + je issp + cmp al,9 + jb isntsp + cmp al,13 + jbe issp +isntsp: xor ax,ax +issp: jmp di +isspace endp + + +;Scrollit - local support to scroll window +; entry: ax = column, bx = line +; exit: ax = column, bx = line +scrollit proc near + cmp bx,[bp+wrt_port].pt_nline ;out of lines? + jl scrl_ret ;no, return + push [bp+wrt_port].pt_text + push [bp+wrt_port].pt_ncols + push [bp+wrt_port].pt_nline + push [bp+wrt_port].pt_ulcol + push [bp+wrt_port].pt_ullin + sub sp,6 ;dummy args for scroll + call scrollup ;scroll window up one line + add sp,16 ;dump args off stack + mov bx,[bp+wrt_port].pt_nline ;bx = number of lines + dec bx ;bx = line number + xor ax,ax ;ax = column +scrl_ret: + ret +scrollit endp + +wstring endp + +;************************************************************************ +;* Perform appropriate VIDEO I/O interrupt * +;* Any difference in register definition should be handled by * +;* the caller except where DH,DL contain row,col information. * +;************************************************************************ + public crt_dsr +crt_dsr proc near + cmp PC_MAKE,TIPC + jne ibm_dsr + int TI_CRT + ret +ibm_dsr: xchg DH,DL ; Do this now instead of making special checks + int IBM_CRT ; IBM's row,col is diff'rnt from TI's col,row + ret +crt_dsr endp + +z_ega proc near + + mov AX,0A000h + mov ES,AX ; set ES to the video plane + mov AX,c_row ; set AX to the row + mul char_hgt ; multiply by the character height + mov BX,80 ; multiply by 80 bytes per line + mul BX + add AX,c_col ; add in the starting column + mov sav_di,AX ; save the starting value + xor BX,BX ; use BX as a counter + mov DX,c_len ; number of columns to blank + +zc_03: mov CX,DX ; restore counter + mov DI,sav_di ; restore index + mov AH,0fh + xor AX,AX ; clear AX + cld +rep stosb + + add sav_di,80 ; next line + inc BX ; increment counter + cmp BX,char_hgt ; done with this row? + jne zc_03 + + xor BX,BX ; clear counter + dec c_nrows ; decrement row count + jg zc_03 ; if more rows, loop (jump) + ret +z_ega endp + +;************************************************************************ +;* Graphics Character Attribute * +;* * +;* Purpose: To retrieve the attribute of a character on an IBM screen * +;* in a graphics mode, either 14 or 16. * +;* * +;************************************************************************ + + public graph_attr +graph_attr proc near + + cmp AL,20h ; skip if a space + je grphend + + cmp AL,00h ; skip if a null + je grphend + + cmp AL,0dbh ; block character? + je grphend + + push ES + push SI + push AX ; save character + push DX ; save row and column + xor AH,AH ; clear AH + mov SI,AX ; use SI as an index + sub SI,21h + + mov AL,DL ; row + mul char_hgt ; pixels per character + xor BX,BX + + mov BL,byte ptr m18_attr[SI] ; default mode 18 adjustment + cmp vid_mode,18 ; are we in mode 18? + je grph_02 ; yes, jump + mov BL,byte ptr m16_attr[SI] ; default mode 16 adjustment + cmp vid_mode,16 ; are we in mode 16? + je grph_02 ; yes, jump + mov BL,byte ptr m14_attr[SI] ; must be mode 14 +grph_02: + add AX,BX + mov BX,80 ; 80 bytes per line + mul BX + + pop DX ; restore the column + xor DL,DL ; clear the row + xchg DH,DL ; set AX to the row + add AX,DX + mov SI,AX ; put result in SI + + mov AX,0a000h ; load in graphics plane + mov ES,AX + + xor CX,CX ; clear CX + + mov CH,01 + mov AH,0 +grph_03: call get_val + + shl CH,1 ; shift mask one bit to the left + inc AH ; next plane + cmp AH,3 + jbe grph_03 + + pop AX ; retrieve character + mov AH,CL ; set attribute byte + pop SI + pop ES +grphend: ret +graph_attr endp + +get_val proc near + push AX ; save AH + mov DX,3ceh ; port addr of sequencer + mov AL,04h ; index to other map mask register + out DX,AL ; set index register + inc DX + xchg AL,AH + out DX,AL ; enable bank + pop AX ; restore AH + mov AL,ES:[SI] + or AL,AL + jz get_end + or CL,CH ; set attribute bit +get_end: ret +get_val endp + +; PCTYPE +; Determine type of PC we are running on and initialize screen. +; +; Returns upon exit: +; Machine Type +; 1 for TIPC or Business Pro in TI mode +; FF for IBM-PC +; FE for IBM-PC/XT +; FD for IBM-PC/jr +; FC for IBM-PC/AT or B-P in IBM mode +; F8 for PS2 Model 80 +; 0 for undeterminable +; Video Mode +; Character Height +; +pctype proc near + push es ; preserve regs for later + push ds + + mov ax,0FC00h ; move paragraph address of copyright +pc_002: mov es,ax ; notice into ES + xor di,di ; Clear DI; 0 is lowest address in ROM @ES: + xor bx,bx ; Flag for "PC_MAKE" + mov cx,40h ; This'll be as far as I go... + mov al,'T' ; look for beginning of "Texas Instruments" + cli ; Stop interrupts - bug in old 8088's +again: + repne scas byte ptr es:[di] ; SEARCH + or cx,cx ; Reach my limit? + jz short pc_005 ; quit if we've exhausted search + cmp byte ptr es:[di],'e' ; make sure this is it + jne again ; use defaults if not found + cmp byte ptr es:[di]+1,'x' ; really make sure this is it + jne again + + push ds + mov ds,bx ; 0->DS for addressing low mem. + + inc bx ; BX==1 => TIPC + mov ax,ds:word ptr [01A2h] ; If TIPC then what kind? + pop ds ; get DS back + + add al,ah ; checkout vector 68 bytes 2 & 3 + cmp al,0F0h ; if AL==F0 then TIPC=Business Pro + jne pc_010 ; jump if not a B-P + + in al,068h ; Read from port + push ax ; Save for later + and al,0FBh ; Enable CMOS + out 068h,al ; Write back out + mov dx,8296h ; I/O address for B-P's mode byte + in al,dx ; TI or IBM Mode on the B-P? + cmp al,0 ; if not zero then B-P emulates a TIPC + pop ax ; Restore original port value + out 068h,al ; and write back out + jne pc_010 ; jump if TIPC else IBM machine code is + ; where it should be. + jmp short pc_007 +pc_005: mov ax,es + cmp ah,0FEh ; test for segment offset FE00 + jae pc_007 ; two checks made? if so, jump + add ah,2 ; go back and check segment offset + jmp pc_002 ; FE00 +pc_007: mov ax,0F000h + + mov es,ax + mov al,byte ptr es:0FFFEh ; IBM's machine code is @F000:FFFE + cmp al,0f0h ; Is this suckah an IBM? + jb pc_010 ; Jump if AL is below F0 (BX will be 0) + mov bl,al +pc_010: + sti ; Turn interrups back on + cmp bx,1 ; TIPC? + jne not_ti ; no, jump +; tipc, initialize graphics + mov di,0DF01h + mov es,di ; clear graphics planes + xor di,di + mov byte ptr es:[di],0AAh ; set red palette + mov byte ptr es:[di]+16,0CCh ; set green palette + mov byte ptr es:[di]+32,0F0h ; set blue palette + + mov ax,0DF82h + mov es,ax + mov byte ptr es:[di],040h ; turn text on + + mov ax,3 ; ax = video mode + ; bx = pc type code + mov cx,8 ; cx = character height + jmp pc_020 +; ibm, (assumed) get current video mode +not_ti: + push bx ; save pc type code around bios calls + mov ax,0500h ; set active display page (for alpha modes) + int 10h ; bios int + mov ah,15 ; get current video mode + int 10h ; bios int + xor ah,ah ; ax = video mode + pop bx ; bx = pc type code + mov cx,8 ; cx = character height + cmp ax,16 ; if video mode = 16 + jle pc_020 ; then + mov cx,14 ; reset character height +pc_020: + pop ds ; restore local data seg + pop es ; es:di addresses transaction buffer + xor di,di + + mov PC_MAKE,bx ; put PC_MAKE in transaction buffer + mov VID_MODE,ax ; ditto video mode + mov CHAR_HGT,cx ; ditto char height + ret +pctype endp + + + page +;----------------------------------------------------------------------------- +; The XLI interface. +;----------------------------------------------------------------------------- + +main proc far ;this file's initial entry point + mov AX,data + mov DS,AX +; mov AX,stack ;establish local stack +; mov SS,AX + + call pctype ;initialize type/monitor info + + mov psp,ES ;save PSP@ + mov word ptr ES:fb_addr,offset file_block ;poke file block@ + mov word ptr ES:fb_addr+2,seg file_block ;into PSP + mov AX,ES:term_addr ;calc ptrs in PCS to jump to + add AX,3 + mov xwait,AX + add AX,3 + mov xbye,AX + mov AX,ES:term_addr+2 + mov xwait+2,AX + mov xbye+2,AX + mov psize,plen ;calc program size + push psp + push psize + call dword ptr [xwait] ;connect with PCS +; Since this is a XLI SYSINT routine, no XCALL's ever cause a return. +; The only time we return is to terminate. + pop AX + pop AX + call dword ptr [xbye] ;disconnect from PCS +main endp + +progsize = $-progstart +plen equ (progsize+datasize+stacksize+100h+10h)/16 +PROG ends + end main + \ No newline at end of file diff --git a/realio.equ b/realio.equ new file mode 100644 index 0000000..ecabbb6 --- /dev/null +++ b/realio.equ @@ -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 , ;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 + 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 + + + \ No newline at end of file diff --git a/realschm.asm b/realschm.asm new file mode 100644 index 0000000..3d64d29 --- /dev/null +++ b/realschm.asm @@ -0,0 +1,1357 @@ +; =====> REALSCHM.ASM +; PC Scheme Real Procedures for Protected Mode Scheme +; (c) 1987 by Texas Instruments Incorporated -- all rights reserved +; Author: Terry Caudill +; History: +; tc 8/07/87 - to work in protected mode scheme (real mode side) +; tc 10/16/87 - modified to use local stack as transaction buffer + + + page 84,120 + name PCSXLI + title PC Scheme External Language Interface + + .286c ;; Utilize the expanded 80286 instruction set + include xli.mac + include xli.ref + include xli.equ + + subttl Stack and Data segment definitions + page + +stksize equ 20000 + +stack segment para stack 'STACK' +s_base db stksize dup (0) +stack ends + +data segment para public 'DATA' + public callers_ds,callers_dx + public load_table,work_area,active_exe +; +; Registers which should be saved due to RPC call +; +trans_buf equ $ +callers_dx dw 0 +callers_ds dw 0 +return_ss dw 0 +return_sp dw 0 +return_bp dw 0 +result_buffer dw 0 + +; +; jump table for specified function requests. this table is position +; dependent - see rpc.equ and pro2real.asm +; +first_sys_func equ 20 ;max number of rpc functions +next_avail_sys dw 0 ;next location in sys_func + +rpc_func dw ret_buffer ;0 - return stack buffer address + dw pctype ;1 - return pc type and graphics info + dw load_exe ;2 - load xli file + dw unload_all ;3 - unload all xli files + dw xesc ;4 - perform xternal escape function + dw ssr_return ;5 - Special Service return + dw takeover_crt ;6 - takeover crt int handler (for exec) + dw restore_crt ;7 - restore system crt int handler + dw 11 dup (unknown_func) ;9 - 19 + +sys_func dd unknown_func,prog ;20 + dd unknown_func,prog ;21 + dd unknown_func,prog ;22 + dd unknown_func,prog ;23 + dd unknown_func,prog ;24 + +; +; The following data structures support the XLI interface +; + +; Various tables +load_table dw N_EXE dup (0) ;PSP addresses (segment) +fb_table dd N_EXE dup (0) ;file block addresses (offset,segment) +pb_table dd N_EXE dup (0) ;parm block addresses (offset,segment) +state_table state N_EXE dup (<>) ;child's regs at point it called us +status_table label word ;records .EXE state (MSBy) and index (LSBy) +x = 0 + rept N_EXE + dw x +x = x+1 + endm + +; Parameter block for EXEC function request +zero equ $ ;a constant zero +exec_pblock dw 0 ;env@ (use Scheme's) + dw zero,seg zero ;cmd line@ (don't care) + dd -1 ;FCB@'s (don't care) + dd -1 + +; Working storage (during a given call to the external routine) + align 16,data +work_area label word ;for dealing with PCS data values + db PAD_SIZE*N_ARGS dup (0) ;during xesc, non-strings go here +; other information required during an xesc call +work_info xesc_struc <> ;general info +swap_table swap_struc N_ARGS dup (<>) ;records swap state for each XCALL arg +bid_name dw 0 ;pointer used for bidding child +; the child currently active or being loaded +active_exe dw 0 ;(same format as status table) + +; State (context) information +; child's registers upon calling PCS +save_ax dw 0 ;actually, we ignore ax..di entries +save_bx dw 0 +save_cx dw 0 +save_dx dw 0 +save_si dw 0 +save_di dw 0 +save_ds dw 0 +save_es dw 0 +save_ss dw 0 +save_sp dw 0 +save_bp dw 0 + +; our registers upon calling child +pcs_state state <> ;our state at point of calling child + + +pc_make dw 1 ;pc type 1 = tipc +crt_sav dw 0,0 ;location to save crt interrupt + +data ends + +prog segment para public 'PROG' + assume cs:prog,ds:data,es:data,ss:stack + + public load_exe,bid_child,c2p_handler,c2p_terminate + public xesc,unload_all,find_open_spot,table_search + public do_floarg,do_fixarg,do_bigarg,do_strarg + public do_floval,do_intval,do_TFval,do_strval + public unload_exe,unload_all + +; RPC_STARTUP +; This routine will be started initially by the protected mode +; application. Return the address of the message handler routine +; in DS:DX. +rpc_init proc far +rpc_startup: + mov ax,cs + mov ds,ax + mov dx,offset rpc_handler + ret +rpc_init endp + +; RPC_HANDLER +; Main control routine for calls to real procedures from protected mode +; scheme. When an RPC is issued, we will get control here. +; +; Upon entry: +; ds:dx => transaction buffer which contains a request. Typically, +; transaction_buffer[0] is an op code, which is used as +; an index into the RPC_FUNC table to determine the actual +; routine to call. Following locations in the transaction +; buffer can be used to pass other parameters and are +; dependent on the function called. +; Upon exit: +; Transaction_buffer[0] should contain an error indication. 0 = no error +; +rpc_handler proc far + int 3 ;for debugging purposes + pusha ;save callers state + +; First of all, lets instantiate our own data segment and save off the +; address of the transaction buffer. + mov ax,ds + mov es,ax ;es => transaction buffer + mov ax,data + mov ds,ax ;ds => our local data + mov callers_ds,es ;save off transaction buffer address + mov callers_dx,dx + mov di,dx + mov bx,es:[di] ;bx = the request opcode + mov word ptr es:[di],0 ;default return value to zero (o.k.) + ;handlers must reset for errors. + cmp bx,first_sys_func ;normal rpc function request? + jb rpc_h010 ;yes, jump + +; Opcodes >= first_sys_func reflect calls to system xli routines, and require +; arguments to be passed on the stack. Protected mode routines stuff the local +; stack segment (defined by STACK above) with the arguments before issueing +; the RPC. The code below must now instantiate the local stack and call a +; handler in the sys_func table above. + mov return_ss,ss ;save current stack segment + mov return_sp,sp ;save current stack pointer + mov return_bp,bp ;save current base pointer + mov ax,stack ;get local stack + mov ss,ax ; and instantiate + mov sp,es:[di]+2 ;transaction_buffer[2] = stack pointer + mov bp,sp ;base pointer = stack pointer + + sub bx,first_sys_func ;calc index into sys_func table + shl bx,1 + shl bx,1 + call dword ptr sys_func+[bx] ;call the routine + + mov ss,return_ss ;restore stack used upon entry + mov sp,return_sp + mov bp,return_bp + les di,dword ptr trans_buf ;restore access to transaction buffer + mov es:[di],ax ;transaction_buffer[0] = return status + jmp rpc_hret ;return to protected mode routine + +; We have a normal rpc call. Our local stack segment may have been stuffed with +; parmameters by the protected mode routine, so lets use it as our extra +; segment (AIA provides a stack segment with the rpc and we can just use it as +; our stack). +; +rpc_h010: + mov ax,stack + mov es,ax + xor di,di ;es:di => pro2real communication buffer + shl bx,1 ;convert func code to index + call rpc_func+[bx] ;call function +rpc_hret: + popa ;restore callers regs + ret ;return to protected mode + +rpc_handler endp + +; UNKNOWN_FUNC +; This routine is called when we get an undefined op-code. Return a +; negative one to the protected mode routine as an error indicator. +; +unknown_func proc near + les di,dword ptr trans_buf ;es:di => transaction buffer + mov word ptr es:[di],-1 ;return error condition + ret +unknown_func endp + +; RET_BUFFER +; Return address of local stack segment. This segment will be used by the +; protected mode routines as a communication buffer between real and protected +; mode. It will be used by other RPC function requests for passing args and +; returning values. For system xli calls, it will be instantiated as the +; stack (see above rpc_handler). +ret_buffer proc near + les di,dword ptr trans_buf ;es:di => transaction buffer + mov es:[di]+2,stksize ;return length of communication buffer + mov ax,offset s_base ;ax = stack base + mov es:[di]+4,ax ;return as communication buffer offset + mov ax,stack ;get buffer segment + mov result_buffer,ax ; and save for later + mov es:[di]+6,ax ;return communication buffer segment + ret +ret_buffer endp + + +; PCTYPE +; Determine type of PC we are running on and initialize screen. +; +; Upon Entry: +; es:di => communication buffer +; +; Upon Exit: +; Communication_buffer[0] = Machine Type +; 1 for TIPC or Business Pro in TI mode +; FF for IBM-PC +; FE for IBM-PC/XT +; FD for IBM-PC/jr +; FC for IBM-PC/AT or B-P in IBM mode +; F8 for PS2 Model 80 +; 0 for undeterminable +; Communication_buffer[2] = Video Mode +; Communication_buffer[4] = Character Height +; +pctype proc near + push es ; save comm buffer + push ds ; save local data seg + + mov ax,0FC00h ; move paragraph address of copyright +pc_002: mov es,ax ; notice into ES + xor di,di ; Clear DI; 0 is lowest address in ROM @ES: + xor bx,bx ; Flag for "PC_MAKE" + mov cx,40h ; This'll be as far as I go... + mov al,'T' ; look for beginning of "Texas Instruments" + cli ; Stop interrupts - bug in old 8088's +again: + repne scas byte ptr es:[di] ; SEARCH + or cx,cx ; Reach my limit? + jz short pc_005 ; quit if we've exhausted search + cmp byte ptr es:[di],'e' ; make sure this is it + jne again ; use defaults if not found + cmp byte ptr es:[di]+1,'x' ; really make sure this is it + jne again + + push ds + mov ds,bx ; 0->DS for addressing low mem. + + inc bx ; BX==1 => TIPC + mov ax,ds:word ptr [01A2h] ; If TIPC then what kind? + pop ds ; get DS back + + add al,ah ; checkout vector 68 bytes 2 & 3 + cmp al,0F0h ; if AL==F0 then TIPC=Business Pro + jne pc_010 ; jump if not a B-P + + in al,068h ; Read from port + push ax ; Save for later + and al,0FBh ; Enable CMOS + out 068h,al ; Write back out + mov dx,8296h ; I/O address for B-P's mode byte + in al,dx ; TI or IBM Mode on the B-P? + cmp al,0 ; if not zero then B-P emulates a TIPC + pop ax ; Restore original port value + out 068h,al ; and write back out + jne pc_010 ; jump if TIPC else IBM machine code is + ; where it should be. + jmp short pc_007 +pc_005: mov ax,es + cmp ah,0FEh ; test for segment offset FE00 + jae pc_007 ; two checks made? if so, jump + add ah,2 ; go back and check segment offset + jmp pc_002 ; FE00 +pc_007: mov ax,0F000h + + mov es,ax + mov al,byte ptr es:0FFFEh ; IBM's machine code is @F000:FFFE + cmp al,0f0h ; Is this suckah an IBM? + jb pc_010 ; Jump if AL is below F0 (BX will be 0) + mov bl,al +pc_010: + sti ; Turn interrups back on + cmp bx,1 ; TIPC? + jne not_ti ; no, jump + +; We have a tipc, initialize the graphics + push 0DF01h + pop es ; clear graphics planes + xor di,di + mov byte ptr es:[di],0AAh ; set red palette + mov byte ptr es:[di]+16,0CCh ; set green palette + mov byte ptr es:[di]+32,0F0h ; set blue palette + + push 0DF82h + pop es + mov byte ptr es:[di],040h ; turn text on + + mov ax,3 ; ax = video mode + ; bx = pc type code + mov cx,8 ; cx = character height + jmp pc_020 + +; We have an ibm, (assumed) get current video mode +not_ti: + push bx ; save pc type code around bios calls + mov ax,0500h ; set active display page (for alpha modes) + int 10h ; bios int + mov ah,15 ; get current video mode + int 10h ; bios int + xor ah,ah ; ax = video mode + pop bx ; bx = pc type code + mov cx,8 ; cx = character height + cmp ax,16 ; if video mode = 16 + jle pc_020 ; then + mov cx,14 ; reset character height +pc_020: + pop ds ; restore local data seg + pop es ; restore communication buffer + xor di,di + mov word ptr es:[di]+0,bx ; put PC_MAKE in transaction buffer + mov word ptr es:[di]+2,ax ; ditto video mode + mov word ptr es:[di]+4,cx ; ditto char height +; +; and just for something different ... lets try some interrupts +; +TI_PBI equ 05Dh ; TI Program Break Interrupt +IBM_PBI equ 01Bh ; IBM Program Break Interrupt +GET_VEC equ 035h +SET_VEC equ 025h + + mov pc_make,bx ;save pc type + mov al,TI_PBI ;default ti program break int + cmp bx,1 ;are we tipc? + je vec_01 ; yes, jump + mov al,IBM_PBI ; no, get ibm pbi +vec_01: + mov ah,GET_VEC ;get vector +fix_010: + push ds ;tempsave data seg + mov dx,offset pbi_brk ;dx=offset of handler + mov cx,cs + mov ds,cx ;ds:dx => handler + int 21h + pop ds ;restore data seg + ret + +pbi_brk: + int 3 ;lets just break and + iret ;ignore for now + +pctype endp + + +ibm_crtint equ 010h +ti_crtint equ 049h + + +; Install new routine at the CRT DSR interrupt +; +takeover_crt proc near + int 3 + push es + push ds ; save segments + + mov ah,035h ;ah = get int vector address + mov al,ibm_crtint ;al = ibm crt interrupt + cmp pc_make,1 ;is it an ibm? + jne take_010 ; yes, jump + mov al,ti_crtint ;al = ti crt interrupt +take_010: + push ax ;save around dos int + int 21h ;get interrupt vector + mov crt_sav+2,es + mov crt_sav,bx ;save existing interrupt vector + pop ax ;restore int + + mov ah,025h ;ah = set int vector, al = int number + mov dx,offset crtdsr + push cs + pop ds ;ds:dx => new interrupt handler + int 21h ;set interrupt vector + pop ds + pop es + ret +takeover_crt endp + +; +; This routine restores the original routine for the CRT DSR interrupt +; +restore_crt proc near + int 3 + push ds ;tempsave data segment + + mov ah,025h ;ah = set int vector address + mov al,ibm_crtint ;al = ibm crt interrupt + cmp pc_make,1 ;is it a ibm? + jne restore_010 ; yes, jump + mov al,ti_crtint ;al = ti crt interrupt +restore_010: + mov dx,crt_sav + mov ds,crt_sav+2 ;ds:dx => system interrupt handler + int 21h ;set interrupt vector + + pop ds ;restore data segment + ret +restore_crt endp + +; +; This is the do-nothing routine installed at the CRT DSR interrupt +; +crtproc proc far +crtdsr: + sti + mov ax,0 + iret +crtproc endp + + +; LOAD_EXE +; Load an XLI file as a child process, setting up all the necessary hooks +; so that it can be called via an xesc, or system xli call. +; +; Upon Entry: +; ES:DI => communication buffer. The structure ld_args (defined below) +; indicates the structure of the buffer. +; Upon Exit: +; The first word in the transaction buffer will be set as follows: +; The high order byte will contain a flags byte where +; success = carry clear +; failure = carry set +; The low order byte will contain the error +; 0 = no open slots +; <> 0 = EXEC failure code + +ld_args struc ;structure of transaction buffer for load exe +sysflag dw ? ;1 = system flag, 0 = user defined +exe_index dw ? ;offset to exe name within pathname +pathname db ? ;pcs-sysdir pathname +ld_args ends + +load_exe proc +; if we succeed, state=EXE_NONE + call find_open_spot ;this sets active_exe + mov ax,0 + jc le_exit ;no open slots +; set state=EXE_TSR for time between EXEC and TSR + load_index itself + mov bh,EXE_TSR + mov active_exe,bx + cmp es:[di].sysflag,1 ;loading system .EXE? + je le_5 ;yes, look only in pcs-sysdir + mov ax,es:[di].exe_index ;get address of filename only + mov bid_name,ax ;try current directory first + call bid_child + jnc le_10 ;bid succeeded, jump +le_5: + mov ax,pathname ;try looking in pcs-sysdir + add ax,di + mov bid_name,ax + call bid_child + jc le_exit ;bid failed, jump +; child is ready, set state=EXE_NORM +le_10: load_index itself + mov bh,EXE_NORM + mov ax,bx + load_index status_table + mov status_table[bx],ax + clc +le_exit: + lahf ;load flags into ah + les di,dword ptr trans_buf ;es:di => transaction buffer + mov es:[di],ax ;move result to rpc buffer + ret +load_exe endp + +;BID_CHILD +; Given a filename in bid_name, initialize it under XLI. +; +; Upon Entry: +; ES:bid_name => pathname of the file to bid +; +; Upon Exit: +; AX = EXEC status +; +; Assume AX..SI are destroyed; DS,ES,SS,SP,BP,DI are preserved. +bid_child proc + push di + push ds ;save parent's state + push es + push bp + save_parent + mov cs:stk_seg,ss + mov cs:stk_offset,sp + + mov dx,bid_name + mov ax,es + mov ds,ax ;DS:DX = parm block + mov bx,data + mov es,bx + lea bx,exec_pblock ;ES:BX = Asciiz pathname + mov ax,FR_EXEC + int 21h + +; The following are external entry points accessible by the child. +biddbg: jmp tsr_done ; --- THE BIG 4 --- (not for child's use) + jmp c2p_handler ; --- THE BIG 4 --- for XCALL's + jmp c2p_terminate ; --- THE BIG 4 --- for child termination + +tsr_done: cli + mov ss,cs:stk_seg + mov sp,cs:stk_offset + sti + pop bp + pop es + pop ds + pop di + ret + +stk_seg dw 0 ;bootstrap parent's state after EXEC +stk_offset dw 0 ;from here + +bid_child endp + + subttl Code segment: Child->Parent Handler + page + +;C2P_HANDLER +; This routine is invoked from the child program bid in BID_CHILD. Upon +; entry we are executing in the child's environment. The relevant stack +; stack entries at this point are: +; SS:SP (top) -> IP ;child's far return address +; CS +; length ;child's length; for TSR +; PSP@ ;child's PSP@ +; //// ;(the rest of the stack) +; The first time called, set up the linkage such that we can get back +; to the routine via the xesc functionality. + +c2p_handler label near + resume_parent + load_index itself + cmp bh,EXE_TSR ;first call (performing TSR) + je c2_10 ; yes, jump + jmp normal ; no, normal call - rejoin xesc +c2_10: + load_index state_table + lea bx,state_table[bx] + mov es,[bx].st_ss + mov bp,[bx].st_sp ;ES:BP is child's SS:SP + mov ax,es:[bp].cs_psp ;get child's PSP off its stack + load_index load_table + mov load_table[bx],ax ;save it + push ds ;-----> DS set to child's PSP + mov ds,ax + mov ax,ds:fb_ptr ;get file block @ + mov cx,ds:fb_ptr+2 + mov dx,ds:env_ptr ;get env block @ (seg addr) + pop ds ;<----- + load_index fb_table + mov word ptr fb_table[bx],ax ;save it + mov word ptr fb_table+2[bx],cx + push es ;tempsave child's SS:SP on stack + push bp + mov bp,ax + mov es,cx ;ES:BP is file block @ + mov ax,es:[bp].fb_pb + mov cx,es:[bp].fb_pb+2 ;get parm block @ + load_index pb_table + mov word ptr pb_table[bx],ax ;save it + mov word ptr pb_table+2[bx],cx +; + test word ptr es:[bp].fb_flags,FB_SYSINT ;system callable? + jz c2_40 ; no, jump + mov ax,es:[bp].fb_sysint_addr + mov cx,es:[bp].fb_sysint_addr+2 ;cx:ax is entry point + mov bx,next_avail_sys ;bx = next avail location + inc next_avail_sys ;bump next avail location + shl bx,1 ;make index + shl bx,1 + mov word ptr sys_func+[bx],ax ;save location in table + mov word ptr sys_func+[bx+2],cx + +c2_40: + int 3 + test word ptr es:[bp].fb_flags,FB_KEEPENV + ;keep child's env block? + jnz c2_50 ;yes, jump + dos_fr FR_RELMEM,,,,,dx ;no, release it for child +c2_50: pop bp + pop es + mov dx,es:[bp].cs_len ;get child's length off its stack +; we're ready to TSR the child + dos_fr FR_TSR,,,dx +; we don't drop through ----------------------------------------- + + + subttl Code segment: Child termination + page + +;C2P_TERMINATE +; After the child has performed its wrapup, it calls this routine +; to deallocate its memory and make its spot in the load table available. +c2p_terminate label near + mov ax,data ;we needn't save child's context now + mov ds,ax + restore_parent + load_index load_table ;release the child + dos_fr FR_RELMEM,,,,,load_table[bx] + jc ct_err + load_index itself ;mark its spot as available + xor bh,bh + mov ax,bx + load_index status_table + mov status_table[bx],ax + jmp normal1 ;rejoin unload_exe +ct_err: mov bx,XLI_ERR_RELMEM + jmp xli_err_exit + + subttl Code segment: xesc + page + +;XESC +; This is the handler for the "%xesc" opcode. +; +; On entry: +; ES:DI => Communication Buffer set up by protected mode routine. +; +; +-----------------------------------------------+ +; | Routine name length (1 word) | +; | Routine name (above length) | +; | . | +; | . | +; | Number of Arguments (1 word) | +; | Type of Arg1 (1 word) | +; | Arg1 (type dependent) | +; | . | +; | . | +; | . | +; | Type of Argn (1 word) | +; | Argn (type dependent) | +; +-----------------------------------------------+ +; +; On exit: +; Communication buffer will contain return status, type, and value +; +; +-----------------------------------------------+ +; | Return Status (1 word) | +; | Return Value Type (1 word) | +; | Return Value (type dependent) | +; | . | +; | . | +; | . | +; +-----------------------------------------------+ +; +; Return Status will either be 0 for normal return, or -1 +; for a special service request. +; +; Return Value Type should be from 0 to N_RV (4) which are +; defined return types, or RV_ERR (10) which allows the +; external program to send back an error message. +; +; Note: Return status for xesc is actually returned in the transaction +; buffer at TRANSACTION_BUFFER[0]. +; Buffer definition for passing data back to protected mode +xesc_result struc +xesc_status dw ? +xesc_vtype dw ? +xesc_value dw ? +xesc_result ends + + +xesc proc near + mov return_sp,sp ;save stack in case errors + + mov ax,ES:[di] ;get string length + mov work_area.srch_slen,ax ;save length of string data + add di,2 + mov work_area.srch_sptr,di ;save address of string data + mov work_area.srch_sptr+2,es + add di,ax ;point past string + mov ax,word ptr es:[di] ;AX = number of args + mov work_info.xs_nargs,ax ;set up number args passed + add di,2 + + mov work_info.xs_pc,di ;and save in local area + mov work_info.xs_pc+2,es + +; Look for a match. + call table_search ;is there a match? + ;(sets active_exe if so) + jnc xesc_10 ;yes, jump + mov bx,XLI_ERR_NO_SUCH_NAME ;error: no such name loaded + jmp xesc_err_exit +xesc_10: mov dx,ax ;tempsave selector +; There was a match. +; Collect the info we'll need to guide us thru xesc call. + load_index fb_table + mov bp,word ptr fb_table[bx] + mov es,word ptr fb_table+2[bx] ;ES:BP is file block @ + + mov ax,es:[bp].fb_id ;get XLI ID + cmp ax,XLI_ID ;compare to our version + je xesc_15 ;if equal, continue + mov bx,XLI_ERR_BAD_VERSION ; else note out of sync + jmp xesc_err_exit +xesc_15: mov ax,es:[bp].fb_flags ;flags + mov work_info.xs_flags,ax + load_index pb_table + mov bp,word ptr pb_table[bx] + mov es,word ptr pb_table+2[bx] ;ES:BP is parm block @ + mov work_info.xs_pb_segment,es ;parm block's segment address + lea ax,es:[bp].pb_rv + mov work_info.xs_rvptr,ax + mov work_info.xs_rvptr+2,es ;return value's address + mov es:[bp].pb_rv,0 ;zero out return value + mov es:[bp].pb_rv+2,0 + mov es:[bp].pb_rv+4,0 + mov es:[bp].pb_rv+6,0 + mov es:[bp].pb_rvtype,SWI_TF ;set ret value's type to T/F + mov es:[bp].pb_ss,0 ;zero out special service + add ax,8 + mov work_info.xs_args,ax ;first arg's address + mov work_info.xs_args+2,es + mov work_info.xs_local,offset work_area ;work area address + mov work_info.xs_local+2,seg work_area +; Begin initializing child's parameter block. + mov es:[bp].pb_select,dx ;store selector into parm block + mov work_info.xs_select,dx + +; Move the xesc arguments to their places for the xesc call. + + mov cx,0 +xesc_20: cmp cx,work_info.xs_nargs ;any left? + je xesc_50 ;no, jump + push cx ;tempsave current arg# + mov bx,cx ;BX = current arg# + shl bx,1 ; make index into swap table + shl bx,1 + mov ax,work_info.xs_args ;get arg address + mov word ptr swap_table[bx].sw_offset,ax ;and save for later + mov si,work_info.xs_pc + mov es,work_info.xs_pc+2 ;ES:SI points to arg type + mov di,word ptr es:[si] + inc si + inc si ;ES:SI points to arg +; Dispatch on argument type + call cs:word ptr do_arg[di] ;handle one type of object + add work_info.xs_local,PAD_SIZE ;incr XLI-local ptr + ;(maintain alignment) + pop cx ;restore current arg# + inc cx + jmp xesc_20 +xesc_50: + call_child 1 ;Call the child. + +; We're back with a return value--unless it's a special service call. +normal: cld + load_index pb_table + mov bp,word ptr pb_table[bx] + mov es,word ptr pb_table+2[bx] ;ES:BP is parm block @ + cmp es:[bp].pb_ss,0 ;any special services? + je xesc_60 ;no, jump + + jmp ssr ;special service. This will + ;return from protected mode + ;to ssr_return before calling + ;the child again at xesc_50 +; Now we're really back with the return value +xesc_60: mov di,es:[bp].pb_rvtype + mov work_area.xs_rvtype,di ;return value's type + + cmp di,RV_ERR ;external-pgm error return? + jne xesc_65 ;no, jump + mov si,work_info.xs_rvptr + mov es,work_info.xs_rvptr+2 ;ES:SI points to return value + ;(external-pgm error message) + shl di,1 ;return type to return + call do_strval ;build the string + jmp xesc_75 ;and return + +xesc_65: cmp di,N_RV ;return value out of range? + jb xesc_70 ;no, jump + mov bx,XLI_ERR_VALUE_BAD_TYPE + jmp xesc_err_exit +xesc_70: shl di,1 + mov si,work_info.xs_rvptr + mov es,work_info.xs_rvptr+2 ;ES:SI point to return value + call cs:word ptr do_val[di] ;handle one type of return value +xesc_75: + mov sp,return_sp ;clean up stack and return + ret + +; This file's error exit processing. Reset the stack so that we return +; correctly. BX should be set with an error code before jumping here. +xli_err_exit: +xesc_err_exit: + les di,dword ptr trans_buf ;es:di => rpc buffer + mov es:[di],bx ;return status + mov sp,return_sp ;clean up stack and return + ret + + + subttl Code segment: Special Services + page + +; "Swap" special service +; On entry, ES:BP is parm block pointer. + +ssr label near + +; mov bx,es:[bp].pb_ss ;get dispatch number +; cmp bx,SS_SWAP +; je ssr_swap +; jmp ss_exit + +ssr_swap: + mov ax,es:[bp].pb_ss_args ;AX = arg# + test work_info.xs_flags,FB_NEAR ;near data? + jnz ssr_10 ; yes, jump +; far data + xor bx,bx ;BX = length (null) + mov cx,bx ;CX = offset (null) + mov dx,bx ;DX = segment(null) + jmp ss_15 +; near data +ssr_10: + mov bx,es:[bp].pb_ss_args+2 ;BX = length + mov cx,es:[bp].pb_ss_args+4 ;CX = destination offset + mov work_info.xs_dest,cx ; save for return trip + mov dx,work_info.xs_pb_segment ;DX = destination segment +ss_15: + + mov di,stack + mov es,di + xor di,di ;ES:DI => result buffer + + mov es:[di].xesc_status,-1 ;SSR request + mov es:[di].xesc_status+2,ax ;arg # + mov es:[di].xesc_status+4,bx ;length + mov es:[di].xesc_status+6,cx ;offset address + mov es:[di].xesc_status+8,dx ;segment address + mov sp,return_sp ;clean up stack + ret ;and return to protected mode + ;routine to copy the string + +ssr_return label near + mov return_sp,sp + les di,dword ptr trans_buf ;load rpc buffer + mov ax,es:[di]+2 ;get # args copied + load_index pb_table + mov bp,word ptr pb_table[bx] + mov es,word ptr pb_table[bx]+2 + mov es:[bp].pb_ss,0 ;Clear ss field for normal exit + mov bx,es:[bp].pb_ss_args ;Get arg# + mov es:[bp].pb_ss_args,ax ;Update # chars copied + shl bx,1 + shl bx,1 ;index into swap table + mov bp,word ptr swap_table[bx].sw_offset ;ES:BP =>arg's loc in parm block. + + test work_info.xs_flags,FB_NEAR ;near data? + jnz ssr_r05 ; yes, jump +; far data + push es ;tempsave + mov bx,stack + mov es,bx + xor di,di ;es:di => result buffer + mov ax,es:[di]+6 ;ax = offset of string + mov bx,es:[di]+8 ;bx = segment of string + pop es ;restore + mov word ptr es:[bp],ax ;put far @ in parm block + mov word ptr es:[bp+2],bx + jmp xesc_50 +; near data +ssr_r05: + mov ax,work_info.xs_dest + mov es:[bp],ax ;put near @ in parm block + jmp xesc_50 + + +;; Jump tables +; indexed by argument type (standard PCS type tag) +do_arg dw do_fixarg ;0=list (#f only) + dw do_fixarg ;1=fixnum + dw do_floarg ;2=flonum + dw do_bigarg ;3=bignum + dw do_fixarg ;4=symbol (#t only) + dw do_strarg ;5=string + dw do_errarg ;6 the rest we don't care about + dw do_errarg ;7 + dw do_errarg ;8 + dw do_errarg ;9 + dw do_errarg ;10 + dw do_errarg ;11 + dw do_errarg ;12 + dw do_errarg ;13 + dw do_errarg ;14 + dw do_errarg ;15 + +; indexed by value type (SW-INT return types) +do_val dw do_intval ;0=integer + dw do_TFval ;1=true/false + dw do_strval ;2=string + dw do_floval ;3=flonum + + +xesc endp + + subttl Code segment: Copy arguments into place for child + page + +; On entry to all the argument handler routines: +; BX = pointer to VM reg with page:offset of Scheme object + +do_floarg proc near + test work_info.xs_flags,FB_NEAR ;near flag on? + jz do_flo10 ;no, jump +; Set up destination address + ; near + mov cx,work_info.xs_args ;dest is in child + mov dx,work_info.xs_args+2 + mov work_info.xs_dest,cx + mov work_info.xs_dest+2,dx + jmp short do_flo20 + ; far +do_flo10: mov cx,work_info.xs_local ;dest is in XLI-local area + mov dx,work_info.xs_local+2 + mov work_info.xs_dest,cx + mov work_info.xs_dest+2,dx +; Copy the flonum data +do_flo20: + mov di,work_info.xs_dest + push ds ;tempsave DS around copy + push es + mov es,work_info.xs_dest+2 ;ES:DI points to dest + pop ds ;DS:SI is Scheme object @ + mov cx,8 + rep movsb + pop ds ;restore our DS + test work_info.xs_flags,FB_NEAR ;near flag on? + jz do_flo30 ;no, jump +; Copy pointer to data + ; near (no copy needed--data is in child's space) + mov cx,8 ;incr arg@ past copied data + jmp short do_flo32 + ; far (pointer in child points to data in XLI space) +do_flo30: sub di,8 ;back up dest @ + mov cx,di + mov dx,es + mov bp,work_info.xs_args + mov es,work_info.xs_args+2 ;ES:BP points to arg position + mov es:[bp],cx + mov es:[bp]+2,dx ;copy pointer there +; Increment arg pointer by an appropriate amount. + mov cx,4 ;incr arg@ past copied ptr +do_flo32: test work_info.xs_flags,FB_PAD ;pad flag on? + jz do_flo35 ;no, skip + mov cx,PAD_SIZE +do_flo35: add work_info.xs_args,cx + add work_info.xs_pc,10 ;update arg counter +do_flo40: ret +do_floarg endp + +do_bigarg proc near + mov ax,es:[si] ;move longint to regs + mov dx,es:[si]+2 + test work_info.xs_flags,FB_NEAR ;near flag on? + jz do_big20 ;no, jump + mov bp,work_info.xs_args + mov es,work_info.xs_args+2 ;ES:BP points to dest + mov es:[bp],ax ;copy LSBy to child + mov cx,2 + test work_info.xs_flags,FB_INT ;is 16-bit integer flag on? + jz do_big15 ;no, jump + ; is the longint small enough for an int? + cmp dx,0 ;DX should be either + ;all 0's or all 1's + je do_big32 ;we can safely truncate + xor dx,0FFFFh ;complement DX + cmp dx,0 ;try again + je do_big32 ;we can safely truncate + mov bx,XLI_ERR_BIG_TO_16_BITS ;error: bignum too big + ;to become int + jmp xesc_err_exit +do_big15: mov es:[bp]+2,dx ;copy MSBy to child + mov cx,4 + jmp short do_big32 + ; far (pointer in child points to data in XLI-local space) +do_big20: +; Copy either the longint or a pointer to it. + mov bp,work_info.xs_args + mov es,work_info.xs_args+2 ;ES:BP points to dest + mov es:[bp],ax ;copy to child + mov es:[bp]+2,dx + mov cx,4 ;incr arg@ past longint + ;or pointer to longint +; Increment arg pointer by an appropriate amount. +do_big32: test work_info.xs_flags,FB_PAD ;pad flag on? + jz do_big35 ;no, skip + mov cx,PAD_SIZE +do_big35: add work_info.xs_args,cx + add work_info.xs_pc,6 ;update arg counter +do_big40: ret +do_bigarg endp + +do_fixarg proc near + mov ax,es:[si] ;move longint to regs + mov dx,es:[si]+2 + mov bp,work_info.xs_args + mov es,work_info.xs_args+2 ;ES:BP points to dest + test work_info.xs_flags,FB_NEAR ;near flag on? + jz do_fix20 ;no, jump + ; near (copy int to child's space) + mov es:[bp],ax ;copy int to child + mov cx,2 ;incr arg@ past int + test work_info.xs_flags,FB_INT ;is 16-bit integer flag on? + jnz do_fix30 ;yes, jump + mov es:[bp]+2,dx ;no, copy high order 16 bits + mov cx,4 ;incr arg@ past longint + jmp short do_fix30 + ; far (pointer in child points to data in XLI-local space) +do_fix20: mov bx,work_info.xs_local + mov [bx],ax + mov [bx]+2,dx + mov ax,work_info.xs_local ;move far ptr to int + ;or longint to child + mov cx,work_info.xs_local+2 + mov es:[bp],ax + mov es:[bp]+2,cx + mov cx,4 ;incr arg@ past ptr to int +; Increment arg pointer by an appropriate amount +do_fix30: test work_info.xs_flags,FB_PAD ;pad flag on? + jz do_fix35 ;no, skip + mov cx,PAD_SIZE +do_fix35: add work_info.xs_args,cx + add work_info.xs_pc,6 ;update arg counter +do_fix40: ret +do_fixarg endp + +do_xxerr: jmp do_errarg ;conditional jumps + ;are too short +do_strarg proc near + add work_info.xs_pc,4 + mov bp,work_info.xs_args + mov es,work_info.xs_args+2 ;ES:BP is arg @ + mov word ptr es:[bp],0 + xor cx,cx + test work_info.xs_flags,FB_NEAR ;Near data? + jnz do_str50 + mov cx,2 + mov word ptr es:[bp+2],0 +do_str50: + add cx,2 + test work_info.xs_flags,FB_PAD ;padding on? + jz do_str65 + mov cx,PAD_SIZE +do_str65: add work_info.xs_args,cx + ret +do_strarg endp + +do_errarg proc near + mov bx,XLI_ERR_ARGN_BAD_TYPE + jmp xesc_err_exit +do_errarg endp + + + subttl Code segment: Copy return value back into Scheme + page + +; On entry to all the value handler routines: +; ES:SI = pointer to return value +; DI = return type +; + +do_floval proc near + push ds ;save for this routine + mov cx,result_buffer + xor dx,dx ;buffer for return values + + test work_info.xs_flags,FB_NEAR ;is near flag on? + mov ax,es + mov ds,ax ;ds now addresses result + jnz do_flv10 ;yes, jump + ; far + mov ax,[si] ;get ptr to number + mov bx,[si]+2 + mov si,ax + mov ds,bx ;DS:SI points to number + ; near +do_flv10: + mov ax,di ;save return type + mov es,cx + mov di,dx ;ES:DI points to result buffer + mov es:[di].xesc_status,0 ; set return status + mov es:[di].xesc_vtype,ax ; set return type + add di,xesc_value ; now address value field + cld + mov cx,8 + rep movsb ; move float to buffer + pop ds + ret +do_floval endp + +do_TFval proc near + mov ax,es:[si] ;get value + or ax,es:[si]+2 ;all bytes must = 0 to be nil + or ax,es:[si]+4 + or ax,es:[si]+6 +; + mov es,result_buffer + xor si,si ;ES:SI points to result buffer + mov es:[si].xesc_status,0 ; set return status + mov es:[si].xesc_vtype,di ; set return type + mov es:[si].xesc_value,ax ; set return value + ret +do_TFval endp + +do_intval proc near + test work_info.xs_flags,FB_NEAR ;near flag on? + jnz do_int10 ;yes, jump + ; far + mov ax,es:[si] ;get ptr to number + mov dx,es:[si]+2 + mov si,ax + mov es,dx ;ES:BP points to number + ; near +do_int10: mov ax,es:[si] ;get number + mov dx,es:[si]+2 + test work_info.xs_flags,FB_INT ;16-bit integer flag on? + jz do_int20 ;no, jump + cwd ;yes, propagate sign +do_int20: + mov es,result_buffer + xor si,si ;ES:SI points to result buffer + mov es:[si].xesc_status,0 ; set return status + mov es:[si].xesc_vtype,di ; set return type + mov es:[si].xesc_value,ax ; set return value + mov es:[si].xesc_value+2,dx + ret +do_intval endp + +do_strval proc near + mov ax,es:[si] + test work_info.xs_flags,FB_NEAR ;is near flag on? + jz do_stv10 ; no, jump + mov dx,work_info.xs_pb_segment ;DX:AX = string ptr + mov cx,es:[si]+2 ;CX = string length + jmp short do_stv15 +do_stv10: mov dx,es:[si]+2 ;DX:AX = string ptr + mov cx,es:[si]+4 ;get string length +do_stv15: mov bx,16380 ;BX is max string length + cmp cx,bx ;is CX short enough + jbe do_stv20 ;yes, jump + mov cx,bx ;no, truncate at max +; DX:AX = string ptr, CX = string length, DI = return type +do_stv20: + mov es,result_buffer + xor si,si ;ES:SI points to result buffer + mov es:[si].xesc_status,0 ; return status + mov es:[si].xesc_vtype,di ; return type + mov es:[si].xesc_value,cx ; length + mov es:[si].xesc_value+2,ax ; pass string pointer back + mov es:[si].xesc_value+4,dx + ret +do_strval endp + +do_errval proc near + mov bx,XLI_ERR_VALUE_BAD_TYPE + jmp xesc_err_exit +do_errval endp + + + subttl Code segment: unload_exe + page + + +; Given active_exe, release it from memory and make its spot available again. +unload_exe proc near + load_index state_table + mov es,word ptr state_table[bx].st_ss + mov bp,word ptr state_table[bx].st_sp ;ES:BP is child's SS:SP + mov es:[bp].cs_psp,0 ;set PSP@ to 0, our signal + ;to child to wrap things up + call_child 2 ;call child one last time +normal1: ret +unload_exe endp + + + subttl Code segment: unload_all + page + +; This routine is called during PCS termination. It notifies each +; child to do any wrapup, then the child will do its final call to us, +; where we release it. + +unload_all proc near + mov active_exe,0 +ua_10: cmp active_exe,N_EXE ;looked at all entries? + je ua_exit ;yes, jump + load_index status_table + mov bx,status_table[bx] + cmp bh,EXE_NONE ;is slot empty? + jne ua_20 ;no, jump +ua_15: inc active_exe ;incr to next entry + jmp ua_10 +ua_20: call unload_exe ;deallocate entry + jmp ua_15 +ua_exit: ret +unload_all endp + + subttl Code segment: table_search + page + +; We need to find a matching string. From it we'll know +; which child has it and what value it maps to. +; On entrance: +; work_area.srch_sptr is the seg:offset of the Scheme string (data proper) +; work_area.slen is the string's length +; On exit: +; if success: AX = selector value +; active_exe = xxnnh, where n is the child +; carry clear +; if fail: carry set +; AX..DI,ES,BP are destroyed. + +table_search proc near + cld ;to be safe + mov work_area.srch_exe,0 +ts_10: cmp work_area.srch_exe,N_EXE ;looked at them all? + jne ts_15 ;no, jump +; No child had a match. Return with carry set. + stc + jmp ts_exit +ts_15: mov bx,work_area.srch_exe + mov active_exe,bx + load_index status_table + mov ax,status_table[bx] + cmp ah,0 ;is this an open spot? + jne ts_20 ;no, jump +ts_next: inc work_area.srch_exe ;increment to next spot + jmp short ts_10 +; We have a loaded file. Figure out where its lookup table is. +ts_20: load_index fb_table + mov bp,word ptr fb_table[bx] + mov es,word ptr fb_table+2[bx] ;ES:BP is file block @ + mov ax,es:[bp].fb_lut + mov dx,es:[bp].fb_lut+2 + mov di,ax + mov es,dx ;ES:DI is lookup table @ + mov ah,0 ;AH will be selector value + mov al,'/' ;AL is name delimiter +; Find the next name in the lookup table. +ts_30: cmp byte ptr es:[di],al ;looking at last delimiter? + je ts_next ;yes, jump + mov si,di ;SI points at current name + mov cx,0FFh + repne scasb ;look for name delimiter + jcxz ts_next ;jump, should've found it by now + mov dx,di ;DI, DX point at next name + mov cx,di + sub cx,si + dec cx ;CX is length of name in table + cmp work_area.srch_slen,cx ;are lengths equal? + jne ts_40 ;no, jump +; We matched lengths. See if the strings themselves match. + mov di,si ;get current name @ back in DI + push ds ;tempsave our DS + mov si,work_area.srch_sptr + mov ds,work_area.srch_sptr+2 ;DS:SI is Scheme string @ + repe cmpsb + pop ds ;restore our DS + je ts_match ;jump if match +; The current table name didn't match. +ts_40: inc ah ;increment selector value + mov di,dx ;restore next name @ to DI + jmp ts_30 +; We matched. Active_exe has child#, replace it with the corr. status value. +; Calculate the selector value (0-based) of the name and return it in AX. +; Clear carry. +ts_match: mov al,ah + xor ah,ah + load_index status_table + mov bx,status_table[bx] + mov active_exe,bx + clc +ts_exit: ret +table_search endp + + subttl Code segment: find_open_spot + page + +; Find an open spot in the load_table. Clear carry and set the LSBy of +; active_exe with the child# if we succeeded, else set carry. +find_open_spot proc near + push bx + push cx + mov cx,N_EXE + mov bx,0 +fi_loop: cmp byte ptr status_table[bx]+1,EXE_NONE + je fi_found + inc bx + inc bx + dec cx + cmp cx,0 + jne fi_loop + stc ;set carry if no available entries + jmp short fi_exit +fi_found: mov bx,N_EXE + sub bx,cx + mov active_exe,bx + clc ;an open entry: clear carry, set active_exe +fi_exit: pop cx + pop bx + ret +find_open_spot endp + +prog ends + + end rpc_startup + \ No newline at end of file diff --git a/regschem.h b/regschem.h new file mode 100644 index 0000000..aae2713 --- /dev/null +++ b/regschem.h @@ -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) + \ No newline at end of file diff --git a/rpc.equ b/rpc.equ new file mode 100644 index 0000000..9cc63d5 --- /dev/null +++ b/rpc.equ @@ -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 + + +  \ No newline at end of file diff --git a/saprop.asm b/saprop.asm new file mode 100644 index 0000000..10c862c --- /dev/null +++ b/saprop.asm @@ -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 + \ No newline at end of file diff --git a/sasm.mac b/sasm.mac new file mode 100644 index 0000000..3359d59 --- /dev/null +++ b/sasm.mac @@ -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 + + \ No newline at end of file diff --git a/sbid.asm b/sbid.asm new file mode 100644 index 0000000..0fb576d --- /dev/null +++ b/sbid.asm @@ -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 + \ No newline at end of file diff --git a/sbigmath.asm b/sbigmath.asm new file mode 100644 index 0000000..d0f94cc --- /dev/null +++ b/sbigmath.asm @@ -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' + JE M3 ; branch if output file name + ENDIF +M10: CMP AL,'=' + JE M4 ; branch if stack size + endif + CMP AL,' ' + JE M11 ; branch if white space + CMP AL,TAB + JNE M12 ; branch if normal arg +M11: DEC CX + JG M1 + XOR CX,CX +M12: JMP M5 ; branch if no args found + ife scheme ; PCS doesn't scan for special args + IF MSDOS EQ 1 +; +; Get input file name +; +M2: MOV DI,OFFSET DGROUP:_INAME + JMP M31 +; +; Get output file name +; +M3: MOV DI,OFFSET DGROUP:_ONAME +; +; Save file name in data area +; +M31: XOR AH,AH +M32: DEC CX + JZ M33 + INC SI + MOV AL,ES:[SI] + CMP AL,' ' + JZ M33 + CMP AL,TAB + JZ M33 + MOV DS:[DI],AL + INC DI + INC AH + CMP AH,32 + JE M34 + JMP M32 +M33: MOV BYTE PTR DS:[DI],0 + JMP M11 +M34: MOV DX,OFFSET DGROUP:NAMERR + JMP NEAR PTR XCABT + ENDIF +; +; Get stack and heap sizes from command line +; +M4: CALL GETNUM ; get stack size + JC M47 ; branch if error + TEST BX,BX + JZ M42A ; bypass if size is 0 + CMP AL,'K' + JE M41 + CMP AL,'k' + JNE M42 ; branch if not kilobytes +M41: TEST BX,0FFC0H + JNZ M47 ; error if size > 63 + XCHG BH,BL ; multiply by 1024 + SHL BH,1 + SHL BH,1 + DEC CX ; advance to next character + JZ M42 + INC SI + MOV AL,ES:[SI] +M42: MOV _STACK,BX ; save stack size +M42A: TEST CX,CX + JZ M5 ; branch if end of command line + CMP AL,' ' + JE M46 ; loop if blank + CMP AL,TAB + JE M46 ; loop if tab + CMP AL,'/' + JNE M47 ; branch if not slash + CALL GETNUM ; get heap size + JC M47 ; branch if error + XOR DX,DX ; long result is in DX,BX + TEST BX,BX + JZ M45 ; branch if size is 0 + CMP AL,'K' + JE M43 + CMP AL,'k' + JNE M44 ; branch if not kilobytes +M43: XCHG BH,BL ; multiply by 1024 + ROL BX,1 + ROL BX,1 + MOV DX,BX + AND BX,0FC00H + AND DX,3FFH + DEC CX ; advance to next character + JZ M44 + INC SI + MOV AL,ES:[SI] +M44: MOV WORD PTR _MNEED,BX ; save heap size + MOV WORD PTR _MNEED+2,DX +M45: TEST CX,CX + JZ M5 ; branch if end of command line + CMP AL,' ' + JE M46 ; loop if blank + CMP AL,TAB + JNE M47 ; error if not tab +M46: JMP M11 +M47: MOV DX,OFFSET DGROUP:STKERR ; abort if stack/heap size error + JMP NEAR PTR XCABT + endif ;matches IFE near M12: +; +; Set up the stack +; + ife scheme ; PCS ignores DOS environment strings + IF LDATA EQ 0 +M5: MOV AX,_XSIZE ; reserve space for environment + ADD AX,15 + AND AX,0FFFEH + ELSE +M5: XOR AX,AX + ENDIF + else +M5: xor ax,ax + endif + + IFDEF PROMEM ;;; Protected Mode + mov bx,_top ; bx = top of stack + jmp M54a +M54: MOV DX,OFFSET DGROUP:MEMERR2 ; abort if error in releasing memory + JMP NEAR PTR XCABT +M54a: + ELSE + MOV BX,_STACK ; get stack size + SHR BX,1 ; make size even + ADD BX,BX + CMP BX,STKMIN + JA M51 + MOV BX,STKMIN ; use default if too small + MOV _STACK,BX +M51: ADD BX,AX ; add environment size + JC M54 ; abort if overflow + MOV DX,ES:2 ; compute available paragraphs + if scheme + mov _paras,dx ; save no. paragraphs for Scheme + endif + MOV AX,SS + SUB DX,AX + TEST DX,0F000H + JNZ M52 ; branch if greater than 64Kbytes + SHL DX,1 ; convert to bytes + SHL DX,1 + SHL DX,1 + SHL DX,1 + JMP M53 +M52: MOV DX,0FFF0H ; use largest value + IF LDATA +M53: CMP DX,BX ; check if stack will fit + JA M55 + ELSE +M53: CMP DX,BX ; check if stack will fit + JB M54 + ADD BX,_BASE ; adjust S/P model for statics + JNC M55 + ENDIF +M54: MOV DX,OFFSET DGROUP:MEMERR2 ; abort if error in releasing memory + JMP NEAR PTR XCABT +M55: CLI + MOV _TOP,BX ; set top-of-stack + MOV SP,BX ; set stack pointer + IF LDATA EQ 0 + MOV AX,DS + MOV SS,AX + ENDIF + MOV _SS,SS + STI + ENDIF ; IFDEF PROMEM + +; +; Set up memory allocation pointers +; + PUSH CX ; save command byte count + + IFDEF PROMEM ;;; Protected Mode + ; Assume small data model + MOV AX,SS ; ax=stack segment + MOV _MBASE+2,AX ; _mbase = top of stack + mov _mbase, bx ; + MOV _MNEXT+2,AX ; _mnext = _mbase + mov _mnext, bx ; + mov bx, 0fff0h ; Protected mode has a full 64K + sub bx, _top ; subtract out top of stack + MOV _MSIZE,BX ; _msize = size of heap pool + xor ax, ax + ELSE + ADD BX,15 ; compute mem pool base segment number + JC M54 + MOV CL,4 + SHR BX,CL + MOV AX,SS + ADD AX,BX + MOV _MBASE+2,AX + MOV _MNEXT+2,AX + MOV BX,ES:2 ; get top segment number + SUB BX,AX ; compute memory pool size + JBE M54 ; branch if insufficient memory + MOV CL,4 ; compute number of bytes + ROL BX,CL + MOV AX,BX + AND AX,15 + AND BX,0FFF0H + MOV _MSIZE,BX + ENDIF + + MOV _MSIZE+2,AX + + PUSH ES ; reset memory pool + PUSH SI + CALL RBRK + POP SI + POP ES + OR AX,AX + JNZ M54 ; branch if not enough memory + + if scheme + IFNDEF PROMEM ;;; Protected Mode - IGNORE + push si + call allmem ; allocate the rest of the data segment + ; to C's heap (small model only); + ; later, in "initmem", PCS will get the + ; rest of MSDOS's memory for itself + pop si + or ax,ax + jnz m54 + ENDIF + endif + + POP DX ; restore command line length +; +; Put return address at top of stack +; + IF MSDOS EQ 1 + PUSH ES ; return is to 1st word of prog prefix + XOR AX,AX + PUSH AX + MOV BP,SP ; BP contains stack linkage + ENDIF +; +; copy command line to stack +; + MOV CX,DX ; get residual command line length + SUB SP,CX ; allocate stack space + DEC SP + MOV DI,SP + MOV DX,SP ; save pointer to end of command + ADD DX,CX + JCXZ M71 ; skip if no bytes to move + PUSH DS ; move them + PUSH ES + POP DS + PUSH SS + POP ES + CLD + REP MOVSB + POP DS +M71: MOV BYTE PTR SS:[DI],0 ; append null byte + MOV WORD PTR _ARG,SP ; save arg array pointer + MOV WORD PTR _ARG+2,SS +; +; Move environment to stack for small data models +; + ife scheme ; PCS ignores DOS environment strings + IF LDATA EQ 0 + MOV CX,_XSIZE ; get extended env size + JCXZ M72 ; branch if no environment + SUB SP,CX ; allocate stack space + MOV DI,SP + PUSH DS ; save important regs + PUSH ES + PUSH SI + PUSH SS ; set stack as destination seg + POP ES + MOV SI,WORD PTR _ENV+2 + MOV WORD PTR _ENV,DI ; save relocated env pointer + MOV WORD PTR _ENV+2,SS + MOV DS,SI ; set env as source + XOR SI,SI + CLD ; move environment + REP MOVSB + POP SI ; restore regs and continue + POP ES + POP DS + ENDIF + endif +; +; Build argument vector +; + ife scheme ; PCS parses its own command line +M72: AND SP,0FFFEH ; make stack pointer even + MOV SI,DX ; prepare to scan command backwards + XOR CX,CX + PUSH CX ; push null terminator for argv + IF LDATA + PUSH CX + ENDIF + MOV BX,SP ; save this null byte address +M8: CMP SI,WORD PTR _ARG ; skip trailing white space + JNE M80 + JMP M83 +M80: DEC SI + CMP BYTE PTR SS:[SI],' ' + JE M8 + CMP BYTE PTR SS:[SI],TAB + JE M8 + MOV BYTE PTR SS:[SI+1],0 ; install null terminator byte + MOV AL,0 ; indicate white space scan + CMP BYTE PTR SS:[SI],'"' + JNE M81 ; branch if not quoted arg + CMP SI,WORD PTR _ARG + JE M81 + CMP BYTE PTR SS:[SI-1],'\' + JE M810 ; branch if \" + MOV AL,'"' ; indicate quote scan + MOV BYTE PTR SS:[SI],0 ; put null in place of quote +M81: CMP SI,WORD PTR _ARG + JE M82 ; branch if no more chars + DEC SI ; position to next char + CMP BYTE PTR SS:[SI],'"' + JNE M81C ; branch if not quote + CMP SI,WORD PTR _ARG + JE M81C ; branch if no more chars + CMP BYTE PTR SS:[SI-1],'\' + JNE M81C ; branch if not \" +M810: PUSH SI ; squish args to remove \ +M81A: DEC SI + CMP SI,WORD PTR _ARG + JE M81B + MOV AH,SS:[SI-1] + MOV SS:[SI],AH + JMP M81A +M81B: INC WORD PTR _ARG + POP SI + JMP M81D +M81C: OR AL,AL + JNZ M82A ; branch if not white space scan +M81D: CMP BYTE PTR SS:[SI],' ' ; find next white space + JE M81E + CMP BYTE PTR SS:[SI],TAB + JNE M81 +M81E: INC SI ; position to start of arg + IF LDATA +M82: PUSH SS ; add arg pointer to vector + PUSH SI + ELSE +M82: PUSH SI ; put arg pointer into argv + ENDIF + INC CX ; bump arg count + JMP M8 ; loop till all args done +M82A: CMP BYTE PTR SS:[SI],'"' ; come here to find starting quote + JNE M81 ; branch if not quote + MOV BYTE PTR SS:[SI],' ' ; replace it with white space + JMP M81E ; go save arg pointer +; +; Construct argv[0] +; +M83: CMP _DOS,2 + JLE M84 + MOV AX,WORD PTR _ENV ; use env trailer for DOS 3 + ADD AX,_ESIZE + INC AX + INC AX + IF LDATA + PUSH [WORD PTR _ENV+2] + ENDIF + PUSH AX + JMP M85 + IF LDATA +M84: PUSH SS ; use null byte for DOS 2 + PUSH BX + ELSE +M84: PUSH BX ; use null byte for DOS 2 + ENDIF +; +; Save argv information +; +M85: INC CX ; save arg count + MOV _ARGC,CX + IF LDATA + MOV WORD PTR _ARGV,SP ; save arg vector pointer + MOV WORD PTR _ARGV+2,SS + ELSE + MOV _ARGV,SP ; save arg vector pointer + ENDIF + + else ; PCS parses its own command line + +; ------------------------------------------------- +; The PCS command line parser +; ------------------------------------------------- + +; The PCS command line can look as follows: +; +; PCS (... ...) atom atom (... ...) "string" atom ... +; +; which parses into PCS-INITIAL-ARGUMENTS as: +; +; ( "(... ...)" "atom" "atom" "(... ...)" "\"string\"" "atom" ... ) +; +; Each command line argument is either an atom, list, or string. +; Each is treated as one argument for the argv vector, and each is +; converted to a string which becomes an element of PCS-INITIAL-ARGUMENTS. +; +; The command line parser is not a Scheme reader. It looks for blank-separated +; tokens, where a token can start with a ( and end with the matching ), +; start and end with a ", or just be a sequence of nonblanks. Backslashed +; delimiters are skipped over as you'd expect. We don't bother with | since +; that is a special character to DOS. The blanks between tokens are important +; since the parser replaces them with nulls to get things set up for C's +; argv vector, so situations like ...)(... won't be parsed correctly. +; The parser is implemented as a finite state automaton (FSA). +; +; The first command line argument has special meaning but that is +; handled in "smain.c". +; + +; On entry to this section: +; ES = SS (but we don't care) +; SP = ptr to start of cmdline +; DX = ptr to cmdline eos (cmdline on stack with eos at its end) + +M72: + push DS ; ES <- DS + pop ES + xor AX,AX ; AH is state, AL is current char + push AX ; push 0 at front of cmdline + ; (we're going to parse backwards) + and SP,0FFFEH ; make SP even + mov SI,DX ; SI is index into cmdline + xor DX,DX ; DH is paren counter, DL is argc + cld +M72loop: dec SI ; get the next char from cmdline + cmp byte ptr SS:[SI-1],'\' ; is it singly escaped? + jne M72a ; no, jump + dec SI ; yes, back up to escape char +M72a: mov AL,SS:[SI] + mov CX,scan_size ; look it up in char table + mov DI,offset scan_table + repne scasb ; put into CX the "char class" for + ; indexing into state table + mov AL,bytes_per_state ; do 2-D subscript into state table + mul AH ; ... row + shl CX,1 ; ... col + add AX,CX + mov BX,AX ; (BH=0 since subscript small enough) + mov AH,state[BX] ; get next state + mov BL,state+1[BX] ; do action routine + add BX,offset actions + jmp BX + +actions label near ; start action routines ----------> +ar_out2: inc SI ; 1 char past token, back up + push SI ; push next argv + dec SI + inc DL ; incr argc +ar_skip: mov byte ptr SS:[SI],0 ; output a null char +ar_decr: jmp short M72loop +ar_lpar: dec DH ; decr paren count + js ar_err ; wrong paren to start with + jnz short M72loop ; on an inner paren, keep looking + mov AH,0 ; override state in table +ar_out1: push SI ; matched delimiter, push next argv + inc DL ; incr argc + jmp short M72loop +ar_rpar: inc DH ; incr paren count + jmp short M72loop +ar_err: mov DX,offset dgroup:parserr ; abort on error in cmdline parsing + jmp near ptr XCABT +ar_out_end: inc SI ; 1 char past token, back up + push SI ; push next argv + dec SI + inc DL ; incr argc +ar_end: ; end action routines <---------- + +continue: xor AX,AX ; argv[0] = \0 + push AX + inc DL ; incr argc + mov _argv,SP ; save address of argv + mov DH,0 + push DX + mov _argc,DX ; save argc + + endif + +; +; Build environment vector +; + ife scheme ; PCS ignores DOS environment strings + XOR AX,AX ; push null terminating pointer + PUSH AX + IF LDATA + PUSH AX + ENDIF + MOV AX,_ENVC ; allocate stack space for vector + ADD AX,AX + JZ M87 ; branch if null environment + SUB SP,AX + IF LDATA + SUB SP,AX + ENDIF + MOV SI,SP ; scan environment + LES DI,_ENV + XOR AX,AX + MOV CX,7FFFH + MOV DX,_ENVC + CLD +M86: MOV SS:[SI],DI + ADD SI,2 + IF LDATA + MOV SS:[SI],ES + ADD SI,2 + ENDIF + DEC DX + JLE M87 + REPNE SCASB + JMP M86 +M87: MOV WORD PTR environ,sp + IF LDATA + MOV WORD PTR environ+2,SS + ENDIF + endif +; +; initialize 8087 numeric data processor +; + IFNDEF PROMEM ;;; Protected Mode - IGNORE + FNINIT ; reset + FNSTSW _NDPSW ; get status + MOV AX,100 ; this is just for delay + MOV DX,AX + IMUL DX + TEST _NDPSW,0B8BFH ; 8087 will reset all these + JNZ M9 + INC _NDP ; indicate ndp present + ENDIF +; +; set up args for _main and call it +; +M9: MOV _SP,SP ; save stack pointer reset value + PUSH DS ; make ES same as DS + POP ES + CALL _MAIN ; call C main + IF MSDOS EQ 1 + CMP _DOS,2 + JL M91 ; branch if DOS 1 + ENDIF + MOV AX,4C00H ; exit with return code of 0 + INT 21H + IF MSDOS EQ 1 +M91: MOV SP,BP ;restore ptr to far return + RET ;return to MS-DOS + ENDIF +;** +; +; name GETNUM -- get a number from the command line +; +; description This function is used internally by the start-up routine +; while processing the command line. +; +;** + ife scheme +GETNUM PROC NEAR + XOR BX,BX ; reset accumulator +NUM1: DEC CX ; advance to next character + JZ NUM3 ; branch if end of command line + INC SI + MOV AL,ES:[SI] + CMP AL,'0' + JL NUM3 ; return if not decimal digit + CMP AL,'9' + JG NUM3 ; return if not decimal digit + SUB AL,'0' ; multiply accumulator by 10 + ADD BX,BX + JC NUM2 + MOV DX,BX + ADD BX,BX + JC NUM2 + ADD BX,BX + JC NUM2 + ADD BX,DX + JC NUM2 + XOR AH,AH ; add this digit + ADD BX,AX + JNC NUM1 ; loop till done +NUM2: RET +NUM3: CLC ; clear carry to indicate no error + RET +GETNUM ENDP + endif + +;** +; +; name XCABT -- Ignominious abort +; +; description This area is entered by direct jump with a message +; pointer in DS:DX. It sends the message to the +; console via DOS function 9 and then aborts. +; + ENTRY XCABT + MOV AH,9 ; print error message + INT 21H + MOV ES,_PSP+2 + IF MSDOS EQ 1 + CMP _DOS,2 + JL A1 + ENDIF + MOV AX,4C01H + INT 21H + IF MSDOS EQ 1 +A1: PUSH ES + XOR AX,AX + PUSH AX + RET + ENDIF + + if scheme +; +; Scheme wrapup - the C fn "exit" calls "_exit" which calls this hook routine +; + public xcexit +DOS equ 21h ; MSDOS function request interrupt +xcexit proc near + + mov bp,sp ; don't lose our return address to _exit + + IFDEF EXPMEM + call rlsexp ; Release Expanded Memory (if any) + ENDIF + + call xli_term ; release all external programs + ; allocated under XLI + IFNDEF PROMEM + push ES ; return Scheme heap to DOS + mov AH,49h + mov ES,first_dos + int DOS + pop ES + jnc MA + MOV DX,OFFSET DGROUP:MEMERR2 ; abort if error in releasing memory + JMP NEAR PTR XCABT + ENDIF +MA: call rsttimer ; Reset the timer interrupt, if necessary + call unfixint ; Restore the keyboard "patch" (MWH2) + call zcuron ; Turn cursor back on + mov AX,15 ; Load character attribute = white,enable + push AX + mov AX,80 ; 80 Columns + push AX + mov AX,25 ; 25 Rows + push AX + xor AX,AX ; Origin at 0,0 + push AX + push AX + call zclear ; Clear the screen + xor AX,AX + push AX + push AX + inc cur_off ; keep cursor off for EGA modes + call zputcur ; Put cursor at 0,0 + mov sp,bp ; reestablish the return address to _exit + ret +xcexit endp + + endif + +CXINIT ENDP + + + IFDEF PROMEM ;;; Protected Mode + +;;; Reset heap break point (unix lingo) +;;; +;;; Set _mbase = _mnext = DS:_top +;;; Set _pool = 0:0, _melt = 0:0 +public rbrk +RBRK PROC NEAR + push bp + mov bp,sp + ; + ; set up memory allocation pointers + ; + mov bx, _top + add bx, 0fh ; round up to para + and bx, 0fff0h + mov _tsize, bx ; total size in paras + + mov ax,ds + mov _mbase+2,ax ; long ptr to heap base + mov _mbase, bx + mov _mnext+2,ax ; long ptr to heap top + mov _mnext, bx + + + xor ax,ax + mov [_msize+2],ax ; number of bytes left in pool + mov _msize, ax + +; Clear the 2nd level pool + mov [_melt],ax + mov [_pool],ax + mov [_melt+02],ax + mov [_pool+02],ax + pop bp + ret +RBRK ENDP + +; + +public lsbrk +lsbrk PROC NEAR + push bp + mov bp,sp + mov cx,[bp+6] ; requested size (high) + mov dx,[bp+4] ; requested size (low) + or cx, cx + jnz lsbrk_err1 + mov cx, 0FFF0h + sub cx, _mnext ; available bytes + cmp cx, dx + jb lsbrk_err1 + mov ax, _mnext ; next location in pool + add _mnext, dx ; bump by requested amount + mov bx, ax + pop bp + ret + +lsbrk_err1: + xor ax,ax + mov bx, ax + pop bp + ret +lsbrk ENDP + + +COMMENT % +;; _RBRK (int desire) +;; desire is initial heap in paras +;; return 0 if OK, ffff otherwise +;; +public _rbrk +;;extrn _model:word +_rbrk proc near + push bp + mov bp,sp + push es +;mov word ptr [_oserr],_model + + mov bx, 0 ;; what is really needed here? 128K? + mov [_tsize],bx ;; really total size with heap + + mov ax,[_mbase] ;; reset heap allocator ptrs + mov [_mnext],ax + mov ax,[_mbase+02] + mov [_mnext+02] ,ax + xor ax,ax + pop es + pop bp + ret +_rbrk_error1: + mov [_oserr],ax +_rbrk_error: + mov ax,0ffffh + pop es + pop bp + ret +_rbrk endp +% + ENDIF +;** +; +; Dummy segment to establish top of program for small program models +; + IF S8086 + IF COM +TAIL SEGMENT WORD 'PROG' + DW -1 +TAIL ENDS + ENDIF + ENDIF + + IF S8086 +PROG ENDS + ENDIF + IF D8086 +CODE ENDS + ENDIF + IF P8086 +_CODE ENDS +OLDCODE SEGMENT BYTE ; This catches Version 2 code + DW 0CACAH +OLDCODE ENDS + ENDIF + IF L8086 +_PROG ENDS +OLDPROG SEGMENT BYTE ; This catches Version 2 code + DW 0CACAH +OLDPROG ENDS + ENDIF + PAGE +;** +; +; DGROUP includes the segments named DATA, UDATA, and XSTACK. The startup +; routine initializes DS to point to this group, and DS must then be pre- +; served throughout the program. The segments within DGROUP are defined +; as follows: +; +; DATA => Contains all static (local and global) initialized items. +; UDATA => Contains all static (local and global) uninitialized items. +; XSTACK => Stack for the startup routine. +; +; During the startup routine, the initial stack (XSTACK) is replaced with +; one that has the correct size for program execution. This size is +; determined by examining the command line and the _STACK global item. Then +; for the S and P memory models, the stack is set up relative to DGROUP (i.e. +; stack items can addressed via DS). For the D and L models, the stack +; segment stands alone and can be up to 64K bytes. +; +; The heap (i.e. the space used by the memory allocator) resides above the +; stack and is also initialized by the startup routine. Any space not +; immediately needed for the heap (as defined by _MNEED) is returned to DOS. +; +; At the end of the startup routine, memory is organized in the following +; sequence: +; +; -- code -- +; -- DATA -- +; -- UDATA -- +; -- stack -- +; -- heap -- +; +; FOR PROPER OPERATION OF THE STANDARD MEMORY ALLOCATOR, THIS SEQUENCE IS +; EXTREMELY IMPORTANT. IF YOU TAMPER WITH THE STARTUP ROUTINE OR INTRODUCE +; SEGMENTS AND CLASSES THAT DO NOT FOLLOW LATTICE CONVENTIONS, CHECK THE +; LOAD MAP CAREFULLY. +; +;** + + +;** +; +; Initialized data +; +DATA SEGMENT PARA PUBLIC 'DATA' + EXTRN _STACK:WORD + EXTRN _MNEED:DWORD + + IFDEF PROMEM ;;; Protected Mode + EXTRN _POOL:WORD + EXTRN _MELT:WORD + ENDIF + + PUBLIC _MODEL,_VER,_TOP,_BASE,_PSP,_MBASE,_MNEXT,_MSIZE,_DSIZE,_PSIZE + PUBLIC _ENV,_DOS,_TSIZE,_ESIZE,_XSIZE,_SS,_SP,_NDP,_NDPSW,_NDPCW + PUBLIC _FPA,_FPERR,_OSERR,_SIGFPE,_ARGV,_ARGC,_ENVC,environ + if scheme + extrn _onexit:word ; our hook into C exit fn + extrn cur_off:byte + public _paras,first_pa,first_dos + endif + IF S8086 +_MODEL DW 0 + ENDIF + IF P8086 +_MODEL DW 1 + ENDIF + IF D8086 +_MODEL DW 2 + ENDIF + IF L8086 +_MODEL DW 3 + ENDIF +_VER DB "LC 3.00",0 +_DOS DB 0 ; DOS major version number + DB 0 ; DOS minor version number +_SS DW 0 ; stack segment number +_SP DW 0 ; SP reset value +_TOP DW 0 ; top of stack (relative to SS) +_BASE DW OFFSET DGROUP:SBASE ; base of stack (relative to DS) +_PSP DW 0 ; program segment prefix pointer + DW 0 +_MBASE DW 0 ; base of memory pool + DW 0 +_MNEXT DW 0 ; next available memory location + DW 0 +_MSIZE DW 0 ; number of bytes left in pool + DW 0 +_TSIZE DW 0 ; total size in paragraphs +_PSIZE DD 0 ; size of program in bytes +_DSIZE DW OFFSET DGROUP:SBASE ; size of static data in bytes + DW 0 + IF LDATA +_ARGV DD 0 ; argument vector pointer +environ DD 0 ; environment vector pointer + ELSE + DD 0 ; *** DOS 2.00 trashing bug *** +_ARGV DW 0 ; argument vector pointer +environ DW 0 ; environment vector pointer + ENDIF +_ARGC DW 0 ; argument count +_ENVC DW 0 ; environment count +_ARG DD 0 ; far pointer to original arg array +_ENV DD 0 ; far pointer to original env array +_ESIZE DW 0 ; environment size in bytes +_XSIZE DW 0 ; extended env size in bytes +_FPA DQ 0 ; floating point accumulator +_FPERR DW 0 ; floating point error code +_NDP DB 0 ; non-zero if 8087 is installed +_NDPSW DW 0FFFFH ; 8087 status word +_NDPCW DW 0 ; 8087 control word +_OSERR DW 0 ; DOS error code + IF LPROG +_SIGFPE DD 0 ; Floating point error signal + ELSE +_SIGFPE DW 0 ; Floating point error signal + ENDIF + + if scheme + +_PARAS DW 0 ; # of paragraphs of memory available +FIRST_PA DW 0 ; seg# of first para. actually used for + ; Scheme heap +FIRST_DOS DW 0 ; seg# of first para. from DOS for + ; Scheme heap + +; the characters sought by PCS's scanner +scan_table db 0,' ()"',0 +scan_size equ $-scan_table + +; the FSA transition table used to parse PCS's command line +; (This once included handling for vertical-bar delimited symbols, but +; DOS's use of | rendered it useless, so it was removed.) + +start_state equ 0 +list_state equ 1 +atom_state equ 2 +strg_state equ 3 +end_state equ 4 +err_state equ 5 + +state label byte + ; initial state + db atom_state,ar_decr-actions ; any char + db strg_state,ar_decr-actions ; " + db list_state,ar_rpar-actions ; ) + db err_state,ar_err-actions ; ( + db start_state,ar_skip-actions ; blank + db end_state,ar_end-actions ; null +bytes_per_state equ $-state + ; in list + db list_state,ar_decr-actions + db list_state,ar_decr-actions + db list_state,ar_rpar-actions + db list_state,ar_lpar-actions ; start_state also possible, see ar_lpar + db list_state,ar_decr-actions + db err_state,ar_err-actions + ; in atom + db atom_state,ar_decr-actions + db atom_state,ar_decr-actions + db atom_state,ar_decr-actions + db atom_state,ar_decr-actions + db start_state,ar_out2-actions + db end_state,ar_out_end-actions + ; in string + db strg_state,ar_decr-actions + db start_state,ar_out1-actions + db strg_state,ar_decr-actions + db strg_state,ar_decr-actions + db strg_state,ar_decr-actions + db err_state,ar_err-actions + +; The exit and error states are not explicitly represented +; in the table, action routines deal with them. + + endif + +STKERR DB "Invalid stack size",0DH,0AH,"$" +MEMERR DB "Insufficient memory",0DH,0AH,"$" + if scheme +memerr2 db "Error in returning memory to DOS",0dh,0ah,"$" +parserr db "Error in parsing command line",0dh,0ah,"$" + endif + + IF MSDOS EQ 1 + PUBLIC _INAME,_ONAME +_INAME DB 32 DUP(0) ; input file name +_ONAME DB 32 DUP(0) ; output file name +NAMERR DB "Invalid I/O redirection",0DH,0AH,"$" + ENDIF +DATA ENDS + + +;** +; +; Uninitialized data +; +UDATA SEGMENT PUBLIC 'DATA' +UDATA ENDS + +;** +; +; The stack segment is included to prevent the warning from the +; linker, and also to define the base (lowest address) of the stack. +; +STKRSV EQU 128 ; reserved stack size +STKMIN EQU 512 ; minimum run-time stack size + IF COM +XSTACK SEGMENT 'DATA' + ELSE +XSTACK SEGMENT STACK 'DATA' + ENDIF +SBASE DB STKRSV DUP (?) +XSTACK ENDS + + END CXINIT + \ No newline at end of file diff --git a/scannum.asm b/scannum.asm new file mode 100644 index 0000000..0cf0af7 --- /dev/null +++ b/scannum.asm @@ -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 + \ No newline at end of file diff --git a/scar_cdr.asm b/scar_cdr.asm new file mode 100644 index 0000000..27f3def --- /dev/null +++ b/scar_cdr.asm @@ -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 ; 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 ; 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 ; 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 + 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>, +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 + C_call set_src_,,Load_ES + restore + 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 ; 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,,Load_ES + add SP,WORDINCR + restore + 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 ; push dest reg number, temp_reg address + C_call alloc_li,,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 ; push arguments to cons + C_call cons,,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 ; 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 ; 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 ; 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 ; 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 ; and push + C_call set_src_,,Load_ES + restore + jmp sch_err + + +car_cdr endp + +prog ends + end + \ No newline at end of file diff --git a/schars.h b/schars.h new file mode 100644 index 0000000..fd62147 --- /dev/null +++ b/schars.h @@ -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'}; + \ No newline at end of file diff --git a/scheme.equ b/scheme.equ new file mode 100644 index 0000000..81cb158 --- /dev/null +++ b/scheme.equ @@ -0,0 +1,5 @@ + include schemed.equ + include schemed.ref + include schemed.mac + include smmu.mac + \ No newline at end of file diff --git a/scheme.h b/scheme.h new file mode 100644 index 0000000..b97ad66 --- /dev/null +++ b/scheme.h @@ -0,0 +1,4 @@ +/* =====> SCHEME.H */ +#include "memtype.h" +#include "schmdefs.h" + \ No newline at end of file diff --git a/schemed.asm b/schemed.asm new file mode 100644 index 0000000..95cd511 --- /dev/null +++ b/schemed.asm @@ -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 + + \ No newline at end of file diff --git a/schemed.equ b/schemed.equ new file mode 100644 index 0000000..1d9ce4f --- /dev/null +++ b/schemed.equ @@ -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 + \ No newline at end of file diff --git a/schemed.mac b/schemed.mac new file mode 100644 index 0000000..4f03730 --- /dev/null +++ b/schemed.mac @@ -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, + 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, + mov rr,[BP].save_&&rr + endm + endm + +; Push multiple +pushm MACRO objs + irp oo, + push oo + endm + endm + +; Pop multiple +popm MACRO objs + irp oo, + pop oo + endm + endm + +; Call Lattice C routine: C_call rtn, +; A call is made to "rtn". If "rtn" has not been declared, an "extrn" +; declaration is generated. "", 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 + irp rr, + mov [BP].save_&&rr,rr + endm +ENDIF +IFNB + mov AX,DS ; make ES point to the current + mov ES,AX ; data segment +ENDIF +IFNDEF rtn + extrn rtn:near +ENDIF + call rtn + endm + + \ No newline at end of file diff --git a/schmdefs.h b/schmdefs.h new file mode 100644 index 0000000..c6a1b9c --- /dev/null +++ b/schmdefs.h @@ -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) + \ No newline at end of file diff --git a/screen.equ b/screen.equ new file mode 100644 index 0000000..d9fb5af --- /dev/null +++ b/screen.equ @@ -0,0 +1,4 @@ +DEFAULT_NUM_ROWS equ 25 +DEFAULT_VGA_ROWS equ 30 +DEFAULT_NUM_COLS equ 80 + \ No newline at end of file diff --git a/scroll.asm b/scroll.asm new file mode 100644 index 0000000..2e1a740 --- /dev/null +++ b/scroll.asm @@ -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 + \ No newline at end of file diff --git a/senv.asm b/senv.asm new file mode 100644 index 0000000..dc20621 --- /dev/null +++ b/senv.asm @@ -0,0 +1,1052 @@ +; =====> SENV.ASM +;*************************************** +;* TIPC Scheme '84 Runtime Support * +;*Interpreter -- Environment Operations* +;* * +;* (C) Copyright 1985 by Texas * +;* Instruments Incorporated. * +;* All rights reserved. * +;* * +;* Date Written: 5 March 1985 * +;* Last Modification: 2 FEB 1987 * +;*************************************** +; +; Modification history +; +; tc 2/10/87 fixed define so that it will define in +; to current environment if not already +; there. + + + + include scheme.equ + include sinterp.mac + + include sinterp.arg + include stackf.equ + +DGROUP group data +data segment word public 'DATA' + assume DS:DGROUP +m_ld_en db "ld-env",0 +m_st_en db "st-env",0 +m_def_en db "define-env",0 +m_en_par db "environment-parent",0 +m_env_lu db "env-lu",0 +m_ld_gl db "ld-global",0 +m_defb db "define!",0 +m_st_gl db "st-global",0 +m_setgnv db "set-global-env!",0 +; Note: the following three (3) definitions are order dependent +lcl_reg equ $ ; local "register" +lcl_disp dw 0 +lcl_page dw 0 +; End of order dependent definitions +data ends + +PGROUP group prog +prog segment byte public 'PROG' + assume CS:PGROUP + +s_env 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 ; All of the above, with "mov SP,BP" first + extrn src_err:near ; "source operand error" message display + extrn printf_c:near ; Error message print routine + extrn not_yet:near ; Feature not yet implemented + extrn sch_err:near ; Link to Scheme level debugger + +; Entry point defined in "svars.asm" + extrn lookup:near + +;************************************************************************ +;* push environment PUSH-ENV list-of-symbols * +;* * +;* Purpose: Scheme interpreter support to "push" a new rib onto the * +;* current heap allocated environment. * +;************************************************************************ + public push_env +push_env: lods byte ptr ES:[SI] ; load code block constant pointer +; allocate new environment object + mov BX,ENV_SIZE-BLK_OVHD ; load size of environment data object, + mov CX,ENVTYPE ; environment type code, and + mov DX,offset tmp_reg ; temporary register address + pushm ; push arguments to 'allocate_block' + C_call alloc_bl,,Load_ES ; allocate new environment object + +; fetch pointer to list-of-symbols + restore + mov BX,AX + shl AX,1 + add BX,AX ; BX <- constant number * 3 + add BX,CB_dis ; add code block displacement to BX + mov AX,ES:[BX].cod_cdis ; load constant from code block + mov DL,ES:[BX].cod_cpag + +; place previous env pointer in new one; update stack frame's env pointer + mov BX,tmp_page ; load pointer to new env object + mov DI,tmp_disp + LoadPage ES,BX +;;; mov ES,pagetabl+[BX] + mov SI,FP ; load current stack frame pointer + xchg BL,S_stack+[SI].sf_hpage ; exchange old/new env pointers + mov ES:[DI].env_ppag,BL + mov CX,DI + xchg CX,word ptr S_stack+[SI].sf_hdisp + mov ES:[DI].env_pdis,CX + +; put list-of-symbols pointer into new environment data object + mov ES:[DI].env_npag,DL ; and store it + mov ES:[DI].env_ndis,AX + +; set tm2_reg to nil (initial empty list of values) + mov byte ptr tm2_page,NIL_PAGE*2 ; set tmp_reg to nil + mov tm2_disp,NIL_DISP + +; count number of symbols in the list-of-symbols + cmp DL,0 ; is list of symbols nil? + je psh_end ; if empty list, jump + mov ES:[DI].env_vpag,NIL_PAGE*2 ; make value list pointer in env + mov ES:[DI].env_vdis,NIL_DISP ; object nil to prevent GC problems + xor CX,CX ; zero the counter + xor BX,BX + mov BL,DL ; copy the list-of-symbols pointer + mov SI,AX ; into BX:SI +psh_enxt: inc CX ; increment list length counter + LoadPage ES,BX ; follow the cdr field of the linked list +;;; mov ES,pagetabl+[BX] ; follow the cdr field of the linked list + mov BL,ES:[SI].cdr_page + mov SI,ES:[SI].cdr + cmp BL,0 ; end of list? + jne psh_enxt + +; set up parameters for call to cons + mov DX,offset nil_reg + mov AX,offset tm2_reg + pushm + mov AX,DS ; load ES for call to Lattice C routine + mov ES,AX + +; create value list of nil pointers (linked through car field) +psh_cons: C_call cons, ; cons a nil value cell + restore ; reload counter + loop psh_cons ; decrement count, loop if not zero + add SP,WORDINCR*3 ; drop arguments off TIPC's stack + +; store pointer to list of values into environment data object + mov BX,tmp_page ; reload environment object pointer (it + LoadPage ES,BX ; may have been moved during the consing +;;; mov ES,pagetabl+[BX] ; may have been moved during the consing + mov DI,tmp_disp ; of the nil values list) +psh_end: mov AL,byte ptr tm2_page ; store pointer to list-of-values + mov ES:[DI].env_vpag,AL ; into env data object + mov AX,tm2_disp + mov ES:[DI].env_vdis,AX + + jmp next_SP ; return to interpreter + +;************************************************************************ +;* hash-environment HASH-ENV * +;* * +;* Purpose: Scheme interpreter support to return a hashed environment * +;* * +;************************************************************************ + public hash_env +hash_env: lods byte ptr ES:[SI] ; load destination register number +; allocate new environment object + mov BX,(HT_SIZE*3)+BLK_OVHD ; size of hashed env + mov CX,ENVTYPE ; environment type code + mov DX,offset tmp_reg ; temporary register address + pushm ; push arguments to 'allocate_block' + C_call alloc_bl,,Load_ES ; allocate new environment object + mov SP,BP + push tmp_disp ; push new environment's displacement + mov BX,tmp_page ; get page offset of new env. + shr BX,1 ; convert to number + push BX ; push new environment's page number + C_call zero_blk ; zero out the new environment + mov SP,BP + mov BX,tmp_page ; Now address the new environment + mov DI,tmp_disp + LoadPage ES,BX ; ES <= address of new environment + mov BX,FP ; get current stack frame pointer + mov AL,S_stack+[BX].sf_hpage ; get current env pointer from stack + mov ES:[DI].env_ppag,AL ; and store in new env object + mov AX,word ptr S_stack+[BX].sf_hdisp + mov ES:[DI].env_pdis,AX + restore ; restore saved regs + mov DI,AX ; DI <= destination register + mov BX,tmp_page ; get page number of new environment + mov byte ptr reg0_pag+[DI],BL ; and place in destination reg + mov BX,tmp_disp ; get disp of new environment + mov reg0_dis+[DI],BX ; and place in destination + jmp next + +;************************************************************************ +;* drop-environment DROP-ENV I(number to drop) * +;* * +;* Purpose: Scheme interpreter support to drop the most recently * +;* allocated rib from the current environment. * +;************************************************************************ + public drop_env +drop_env: lods byte ptr ES:[SI] ; load drop count + save ; save the current location pointer + mov CX,AX ; copy drop count to CX + mov DI,FP ; load the current stack frame pointer + xor BX,BX + mov BL,S_stack+[DI].sf_hpage ; load environment pointer from + mov SI,word ptr S_stack+[DI].sf_hdisp ; the current stack frame +drop_lp: LoadPage ES,BX +;;; mov ES,pagetabl+[BX] + mov BL,ES:[SI].env_ppag ; copy parent's pointer from environment + mov SI,ES:[SI].env_pdis + loop drop_lp + mov S_stack+[DI].sf_hpage,BL ; rib into the stack frame + mov word ptr S_stack+[DI].sf_hdisp,SI + jmp next_PC ; return to interpreter + +;************************************************************************ +;* Macro Support for load/store-environment * +;************************************************************************ +ld_st macro direction,text + local x,y + lods word ptr ES:[SI] ; load operands + xor BH,BH + mov BL,AL ; copy destination register number + mov DI,BX ; into TIPC register DI and + add DI,offset reg0 ; compute its address + save ; save location pointer, dest reg address + mov BL,AH ; copy constant number into + mov DI,BX ; TIPC register DI + shl BX,1 + add DI,BX ; DI <- constant number * 3 + add DI,CB_dis ; compute address of code block constant + xor BH,BH + mov BL,ES:[DI].cod_cpag ; load symbol's page number + cmp byte ptr ptype+[BX],SYMTYPE*2 ; it is a symbol, isn't it? + jne x ; if not a symbol, error (jump) +; call "srch_all" to search the current environment + mov CX,BX ; copy symbol pointer into CX:DX + mov DX,ES:[DI].cod_cdis + mov SI,FP ; load current stack frame pointer + mov BL,S_stack+[SI].sf_hpage ; load current env pointer into + mov SI,word ptr S_stack+[SI].sf_hdisp ; BX:SI + call srch_all ; search environment for symbol + restore ; reload destination register address + cmp BL,0 ; was symbol found in environment? + je y ; if not found, error (jump) + LoadPage ES,BX +;;; mov ES,pagetabl+[BX] +IFIDN , +; return value from cdr field of value cell returned by "srch_all" + mov AL,ES:[SI].cdr_page + mov byte ptr [DI].C_page,AL ; store value in destination register + mov AX,ES:[SI].cdr + mov [DI].C_disp,AX +ELSE +IFIDN , +; store value into cdr field of returned value cell + mov AL,byte ptr [DI].C_page ; store value into cdr field + mov ES:[SI].cdr_page,AL ; of cell + mov AX,[DI].C_disp + mov ES:[SI].cdr,AX +ELSE + ***error*** Invalid 'direction' +ENDIF +ENDIF +; return to the Scheme interpreter + jmp next_PC +; ***error-- operand is not a symbol*** +x: lea BX,text ; load text for instruction's name + jmp src_err ; display "source operand error" message +; ***error-- symbol not found in environment*** +y: corrpage CX +IFIDN , + xor AX,AX ; signal current environment being used + pushm ; push arguments for call + C_call sym_unde,,Load_ES ; call: sym_undefined(pg,ds,env,dest); +ELSE + pushm ; push arguments for call + C_call not_lexi,,Load_ES ; call: not_lexically_bound(pg,ds); +ENDIF + restore ; load next instruction's offset and + sub SI,3 ; back it up to retry the ld/st + jmp sch_err ; link to Scheme debugger + endm + +;************************************************************************ +;* Load From Environment LD-ENV R(dest),C(symbol) * +;* * +;* Purpose: Scheme interpreter support to load from the current * +;* environment. * +;************************************************************************ + public ld_env +; load and process operands +ld_env: ld_st load,m_ld_en + +;************************************************************************ +;* Store Into Environment ST-ENV R(value),C(symbol) * +;* * +;* Purpose: Scheme interpreter support to store into the current * +;* environment. * +;************************************************************************ + public st_env +; load and process operands +st_env: ld_st store,m_st_en + + purge ld_st + +;************************************************************************ +;* AL AL AH * +;* Define in Environment DEFINE R(d=s1),R(s2),R(s3) * +;* s1=sym,s2=val,s3=env/nil * +;* * +;* Purpose: Scheme interpreter support to define a symbol in a given * +;* environment. This routine supports the MIT Scheme construct * +;* (set! (access sym env) value). In essence, the current env * +;* is searched for sym. If found, then its binding is modified * +;* to value. Otherwise, a new binding is added to the current * +;* environment. * +;************************************************************************ +; ***error-- invalid operand for define*** +def_en_x: mov BX,offset m_def_en ; load "def-env" text + jmp src_err ; display "invalid source operand" message + + public def_env +def_env: lods byte ptr ES:[SI] ; load symbol operand + mov DI,AX ; copy symbol register number to + add DI,offset reg0 ; DI and compute the register's address + lods word ptr ES:[SI] ; load value/environment operands + save ; save loc ptr, dest reg addr, val/env opnds +; validate and load the symbol operand + mov BX,[DI].C_page ; fetch the symbol's page number + cmp byte ptr ptype+[BX],SYMTYPE*2 ; is first operand a symbol? + jne def_en_x ; if not a symbol, error (jump) + mov CX,BX ; place symbol pointer into CX:DX + mov DX,[DI].C_disp +; validate and load environment operand + mov BL,AH ; copy env register number to BX + mov SI,reg0_dis+[BX] ; load environment pointer into BX:SI + mov BL,byte ptr reg0_pag+[BX] + cmp byte ptr ptype+[BX],ENVTYPE*2 ; is it an envirnoment object? + je def_e_ok ; if an environment, jump + cmp BL,0 ; is it a nil pointer? + jne def_en_x ; if not nil, error (invalid operand; jump) + mov SI,FP ; load pointer to current stack frame + mov BL,S_stack+[SI].sf_hpage ; default environment to current + mov SI,word ptr S_stack+[SI].sf_hdisp ; environment +; search environment for the symbol +def_e_ok: pushm ; save environment pointer on stack + call srch_all ; search all rib's + restore ; restore 2nd and 3rd operands + cmp BL,0 ; was symbol found? + je def_bind ; if not found, jump + LoadPage ES,BX ; load value cell page's paragraph address +;;; mov ES,pagetabl+[BX] ; load value cell page's paragraph address + mov BL,AL ; copy value register number to BX + mov AL,byte ptr reg0_pag+[BX] ; set cdr of value cell to the + mov ES:[SI].cdr_page,AL ; contents of the value register + mov AX,reg0_dis+[BX] + mov ES:[SI].cdr,AX + jmp next_SP ; return to interpreter + +; Symbol not found in environment -- bind it in given rib +def_bind: restore ; restore symbol register address + pop [BP].temp_reg.C_disp ; restore env pointer in local temp_reg + pop [BP].temp_reg.C_page + mov BL,AL ; compute value register address + add BX,offset reg0 + lea SI,[BP].temp_reg ; load tmp_reg address + pushm ; push args to bind_it + call bind_it ; bind symbol in environment + jmp next_SP ; return to interpreter + +;************************************************************************ +;* Set Global Environment SET-GLOB-ENV! R(value) * +;* * +;* Purpose: Scheme interpreter support to initialize the Global * +;* Environment Register (GNV_reg). * +;************************************************************************ + public set_gnv +set_gnv: lods byte ptr ES:[SI] ; load operand + mov DI,AX ; copy source register number to DI and + add DI,offset reg0 ; compute source/destination reg address + mov AX,[DI].C_disp ; load pointer to new global environment + mov BX,[DI].C_page + cmp byte ptr ptype+[BX],ENVTYPE*2 ;it's an environment, isn't it? + jne set_g_er ; if operand not env, error (jump) + xchg byte ptr GNV_pag,BL ; copy env pointer to GNV_reg + xchg GNV_dis,AX + mov byte ptr [DI].C_page,BL ; store previous value of GNV_reg + mov [DI].C_disp,AX ; into the destination register + jmp next ; return to interpreter +; ***error-- operand is not an environment object*** +set_g_er: save ; save the location pointer + mov BX,offset m_setgnv ; load text for "set-global-env!" + jmp src_err ; display "source operand error" message + +;************************************************************************ +;* AL AH * +;* Load from Global Environment LD-GLOBAL R(d),C(s1) * +;* s1=symbol * +;* * +;* Purpose: Scheme interpreter support to retrieve values for symbols * +;* defined in the current global environment. * +;* * +;* Note: This instruction is an optimization of the LD-ENV operation. * +;* Here, the environment operand defaults to the current * +;* global environment, which is pointer to by GNV_reg. * +;************************************************************************ + public ld_globl +ld_globl: lods word ptr ES:[SI] ; load operands + mov BL,AL ; copy the destintation register + mov DI,BX ; into TIPC register DI and compute + add DI,offset reg0 ; the destination register's address + save ; save said, and the location pointer +; validate the symbol operand and load symbol pointer + mov BL,AH ; copy the constant number + mov SI,BX ; SI <- constant number * 3 + shl SI,1 + add SI,BX + add SI,CB_dis ; add in displacement of current code block + mov BL,ES:[SI].cod_cpag ; load symbol's page number + mov DX,ES:[SI].cod_cdis ; load symbol pointer into CX:DX +ld_gl_x: cmp byte ptr ptype+[BX],SYMTYPE*2 ; it is a symbol, isn't it? + jne ld_g_err ; if not a symbol, error (jump) + mov CX,BX +; load pointer to the global environment + mov BL,byte ptr GNV_pag + mov SI,GNV_dis +; search the global environment for the symbol-- test to see if found + pushm ; save symbol pointer + call srch_all ; search global environment + restore ; reload destination register address + cmp BL,0 ; was symbol found? + je ld_g_nf ; if not found, error (jump) +; copy cdr field of value cell returned into the destination register + LoadPage ES,BX +;;; mov ES,pagetabl+[BX] + mov AL,ES:[SI].cdr_page ; copy cdr field of value cell + mov byte ptr [DI].C_page,AL ; into destination register + mov AX,ES:[SI].cdr + mov [DI].C_disp,AX + jmp next_SP ; return to interpreter +; ***error-- symbol operand wasn't a symbol pointer*** +ld_g_err: mov BX,offset m_ld_gl ; load text for "ld-global" + jmp src_err ; display "invalid source operand" message +; ***error-- global symbol not found*** +ld_g_nf: popm ; restore symbol pointer + corrpage CX ; correct page number for call to C + mov AX,offset GNV_reg ; load address of global env register + pushm ; push arguments for call + C_call sym_unde,,Load_ES ; call: sym_undefined(pg,ds,env,dest) + restore ; load next intstruction's offset and + sub SI,3 ; back up location pointer to retry load + jmp sch_err ; link to Scheme debugger + +;************************************************************************ +;* AL AH * +;* Load from Global Environment (reg operand) LD-GLOBAL-R R(d),R(s1) * +;* s1=symbol * +;* * +;* Purpose: Scheme interpreter support to retrieve values for symbols * +;* defined in the current global environment. * +;* * +;* Note: This instruction is an optimization of the LD-ENV operation. * +;* Here, the environment operand defaults to the current * +;* global environment, which is pointer to by GNV_reg. * +;************************************************************************ + public ld_globr +ld_globr: lods word ptr ES:[SI] ; load operands + mov BL,AL ; copy the destintation register + mov DI,BX ; into TIPC register DI and compute + add DI,offset reg0 ; the destination register's address + save ; save said, and the location pointer +; load symbol pointer + mov BL,AH ; copy the symbol's register number + mov DX,reg0_dis+[BX] ; load symbol's displacement + mov BL,byte ptr reg0_pag+[BX] ; load symbol's page number + jmp ld_gl_x ; continue process as ld-global + +;************************************************************************ +;* AL AH * +;* Define in Global Environment DEFINE! R(d=s1),C(s2) * +;* s1=value,s2=symbol * +;* * +;* Purpose: Scheme interpreter support to assign a variable in the * +;* current "global" environment. * +;* * +;* Note: This instruction is an optimization of the DEFINE-ENV * +;* operation. Here, the environment operand defaults to * +;* the current global environment, which is pointed to by * +;* GNV_reg. * +;************************************************************************ + public define +define: lods word ptr ES:[SI] ; load operands + mov BL,AH ; copy constant number to BX + xor AH,AH + mov DI,AX ; copy value/destination register number + add DI,offset reg0 ; to DI and compute the register's address + save ; save location pointer, dest reg address +; validate symbol operands and load it into CX:DX + mov SI,BX ; copy constant number into SI + shl SI,1 + add SI,BX ; SI <- constant number * 3 + add SI,CB_dis ; add starting offset of current code block + mov BL,ES:[SI].cod_cpag ; load symbol's page number + cmp byte ptr ptype+[BX],SYMTYPE*2 ; it is a symbol, isn't it? + jne defb_err ; if not a symbol, error (jump) + mov CX,BX ; put symbol pointer into CX:DX + mov DX,ES:[SI].cod_cdis + pushm ; save pointer to symbol +; load global environment pointer into BX:SI + mov BL,byte ptr GNV_pag + mov SI,GNV_dis +; search the global environment for the symbol-- test to see if found + call srch_env + cmp BL,0 + je defb_new +; symbol was found-- set cdr of field returned to the value specified + restore + LoadPage ES,BX +;;; mov ES,pagetabl+[BX] + mov AL,byte ptr [DI].C_page + mov ES:[SI].cdr_page,AL + mov AX,[DI].C_disp + mov ES:[SI].cdr,AX + jmp next_SP ; return to interpreter +; symbol wasn't found-- create new binding in current global environment +defb_new: mov AX,SP ; get address of symbol + +; In case you're wondering what just went on with the above instruction, +; the page and displacement of the symbol to be bound are residing in the +; correct order on the top of the stack. The "mov AX,SP" captures the +; address of said pointer so that it may be used as an argument to +; sym_bind, below. + + mov BX,offset GNV_reg ; load GNV_reg address (contains env ptr) + pushm ; push sym,val,env register pointers + call bind_it ; create binding in global environment + jmp next_SP ; return to interpreter +; ***error-- symbol operand wasn't a symbol*** +defb_err: mov BX,offset m_defb + jmp src_err + +;************************************************************************ +;* AL AH * +;* Define in Global Environment ST-GLOBAL R(d=s1),C(s2) * +;* s1=value,s2=symbol * +;* * +;* Purpose: Scheme interpreter support to assign a variable in the * +;* current "global" environment. * +;* * +;* Note: This instruction is an optimization of the ST-ENV * +;* operation. Here, the environment operand defaults to * +;* the current global environment, which is pointed to by * +;* GNV_reg. * +;************************************************************************ + public st_globl +st_globl: lods word ptr ES:[SI] ; load operands + mov BL,AH ; copy constant number to BX + xor AH,AH + mov DI,AX ; copy value/destination register number + add DI,offset reg0 ; to DI and compute the register's address + save ; save location pointer, dest reg address +; validate symbol operands and load it into CX:DX + mov SI,BX ; copy constant number into SI + shl SI,1 + add SI,BX ; SI <- constant number * 3 + add SI,CB_dis ; add starting offset of current code block + mov BL,ES:[SI].cod_cpag ; load symbol's page number + cmp byte ptr ptype+[BX],SYMTYPE*2 ; it is a symbol, isn't it? + jne st_gl_er ; if not a symbol, error (jump) + mov CX,BX ; put symbol pointer into CX:DX + mov DX,ES:[SI].cod_cdis + pushm ; save pointer to symbol +; load global environment pointer into BX:SI + mov BL,byte ptr GNV_pag + mov SI,GNV_dis +; search the global environment for the symbol-- test to see if found + call srch_all + restore + cmp BL,0 + je st_gl_nf +; symbol was found-- set cdr of field returned to the value specified + LoadPage ES,BX +;;; mov ES,pagetabl+[BX] + mov AL,byte ptr [DI].C_page + mov ES:[SI].cdr_page,AL + mov AX,[DI].C_disp + mov ES:[SI].cdr,AX + jmp next_SP ; return to interpreter +; symbol wasn't found-- inquire from user as to what to do +st_gl_nf: popm ; restore pointer to symbol + corrpage CX ; adjust page number for C call + pushm ; push page, disp, value reg address + C_call not_glob,,load_ES ; resolve error situation + restore ; load next instruction's offset and back + sub SI,3 ; location pointer up to retry the store + jmp sch_err ; link to Scheme debugger +; ***error-- invalid operand to st-global*** +st_gl_er: mov BX,offset m_st_gl + jmp src_err + +;************************************************************************ +;* Environment Predicate ENV? object * +;* * +;* Purpose: Scheme interpreter support to test for an environment * +;* data object. * +;************************************************************************ + public env_p +env_p: lods byte ptr ES:[SI] ; load the operand + mov DI,AX ; and copy into TIPC register DI + mov BX,reg0_pag+[DI] ; load the operand's page number + cmp byte ptr ptype+[BX],ENVTYPE*2 ; is operand an environment? + je env_t ; if an environment object, jump +; object not an env-- return a value of nil in the destination register + mov byte ptr reg0_pag+[DI],NIL_PAGE*2 + mov reg0_dis+[DI],NIL_DISP*2 + jmp next ; return to interpreter +; object is an env-- return a value of 't in the destination register +env_t: mov byte ptr reg0_pag+[DI],T_PAGE*2 + mov reg0_dis+[DI],T_DISP*2 + jmp next ; return to interpreter + +;************************************************************************ +;* Make Environment MK-ENV dest * +;* * +;* Purpose: Scheme interpreter support to return a pointer to the * +;* current environment. * +;************************************************************************ + public mk_env +mk_env: lods byte ptr ES:[SI] ; load destination register number + mov DI,AX ; and put it in TIPC register DI + mov BX,FP ; load the current stack frame pointer + mov AL,S_stack+[BX].sf_hpage ; load current env pointer from stack + mov byte ptr reg0_pag+[DI],AL; and put in destination register + mov AX,word ptr S_stack+[BX].sf_hdisp + mov reg0_dis+[DI],AX + jmp next ; return to interpreter + +;************************************************************************ +;* Environment Parent ENV-PARENT env * +;* * +;* Purpose: Scheme interpreter return the "parent" of a given * +;* environment. * +;************************************************************************ + public env_par +env_par: lods byte ptr ES:[SI] ; load the environment operand + save ; save the current location pointer + mov DI,AX ; copy operand register number to DI + mov BX,reg0_pag+[DI] ; load operand's page number + cmp byte ptr ptype+[BX],ENVTYPE*2 ; is operand an environment? + jne env_p_er ; if not an environment, error (jump) + mov SI,reg0_dis+[DI] ; load pointer to environment object + LoadPage ES,BX +;;; mov ES,pagetabl+[BX] + mov AL,ES:[SI].env_ppag ; load parent pointer from env object + mov byte ptr reg0_pag+[DI],AL ; and put in destination register + mov AX,ES:[SI].env_pdis + mov reg0_dis+[DI],AX + jmp next_PC ; return to interpreter +; ***error-- invalid operand*** +env_p_er: lea BX,m_en_par ; load text addr for "environment-parent" + jmp src_err ; display "invalid source operand" message + +;************************************************************************ +;* Lookup In Environment ENV-LU R(d=s1),R(s2) * +;* s1=symbol,s2=env * +;************************************************************************ + public env_lu +env_lu: lods word ptr ES:[SI] ; load operands +; fetch and validate first operand (symbol pointer) + xor BH,BH + mov BL,AL + mov DI,BX + add DI,offset reg0 + save ; save location pointer; dest reg address + mov CX,[DI].C_page ; copy symbol pointer into CX:DX + mov DX,[DI].C_disp + mov BX,CX ; test to make sure that first operand + cmp byte ptr ptype+[BX],SYMTYPE*2 ; is a symbol + jne env_lu_x ; if not a symbol, error (jump) +; fetch and validate second operand (environment pointer) + mov BL,AH ; copy env register number + mov SI,reg0_dis+[BX] ; copy environment pointer into BX:SI + mov BL,byte ptr reg0_pag+[BX] + cmp byte ptr ptype+[BX],ENVTYPE*2 ; it is an env, isn't it? + jne env_lu_x ; if operand not environment, error (jump) +; search the environment for the symbol + call srch_all ; search all ribs +; store result of search into destination register + restore ; reload the destination register address + mov byte ptr [DI].C_page,BL + mov [DI].C_disp,SI + jmp next_PC ; return to interpreter +; ***error-- invalid operand*** +env_lu_x: mov BX,offset m_env_lu + jmp src_err + +s_env endp + +;************************************************************************ +;* Local Support - Search Environment (all of it) * +;* * +;* Input Parameters: CX:DX - search symbol * +;* BX:SI - environment chain pointer * +;* * +;* Output Parameters: BX:SI - value cell for symbol * +;************************************************************************ +srch_all proc near + pushm ; save pointer to current rib + call srch_env ; search rib for desired symbol + cmp BX,0 ; was symbol found? + jne srch_ok ; if symbol found, jump + popm ; restore pointer to current rib + LoadPage ES,BX +;;; mov ES,pagetabl+[BX] ; load pointer to parent rib + mov BL,ES:[SI].env_ppag + mov SI,ES:[SI].env_pdis + cmp BX,0 ; does parent rib exist? + jne srch_all ; if no parent, symbol not found (jump) + jmp short srch_nok +srch_ok: add SP,WORDINCR*4 ; dump env pointer off stack +srch_nok: ret ; return search result to caller +srch_all endp + +;************************************************************************ +;* Local Support - Search Environment (one rib) * +;* * +;* Input Parameters: CX:DX - search symbol * +;* BX:SI - environment chain pointer * +;* * +;* Output Parameters: BX:SI - value cell for symbol * +;************************************************************************ +srch_env proc near + LoadPage ES,BX ; load paragraph address of env chain +;;; mov ES,pagetabl+[BX] ; load paragraph address of env chain + cmp ES:[SI].env_len,ENV_SIZE ; hash table or "rib"? + jne srch_ht ; if hash table, jump + pushm ; save pointer to environment +;;;; pushm ; save pointer to environment + mov AX,1 ; initialize counter + xor BX,BX + mov BL,ES:[SI].env_npag ; load pointer to list of symbols + mov SI,ES:[SI].env_ndis +srch_mor: cmp BL,0 ; more symbols in this rib? + je srch_nf ; if end of symbol list, jump + LoadPage ES,BX +;;; mov ES,pagetabl+[BX] + cmp DX,ES:[SI].car ; is symbol disp eq to this entry? + jne srch_nxt ; if no match, jump + cmp CL,ES:[SI].car_page ; is page number eq? + je srch_fnd ; if symbol's page number eq, jump +srch_nxt: inc AX ; increment symbol count + mov BL,ES:[SI].cdr_page ; follow cdr field of linked list + mov SI,ES:[SI].cdr + jmp short srch_mor ; loop +srch_fnd: mov CX,AX ; move counter symbol counter to CX + popm ; recover pointer to environment chain + LoadPage ES,BX +;;;; popm ; recover pointer to environment chain + mov BL,ES:[SI].env_vpag ; load pointer to value list + mov SI,ES:[SI].env_vdis + jmp short srch_f1 +srch_lp: LoadPage ES,BX ; follow chain through car field of linked +;;; mov ES,pagetabl+[BX] ; follow chain through car field of linked + mov BL,ES:[SI].car_page ; list + mov SI,ES:[SI].car +srch_f1: loop srch_lp ; not value entry for symbol, loop (jump) + ret ; return to caller +; symbol not found-- return nil +srch_nf: add SP,WORDINCR*2 ; drop env pointer off stack + ret ; return to caller +; +; Hash Table Rib Format +; +srch_ht: pushm ; save arguments to srch_env + mov lcl_page,CX ; store symbol pointer in tmp_reg + mov lcl_disp,DX + mov AX,offset lcl_reg ; load address of lcl_reg and push + push AX ; it as an argument to sym_hash + call sym_hash ; get the hash value for the symbol + add SP,WORDINCR ; drop the argument off the stack + cmp AX,HT_SIZE ; valid hash value returned? + jae srch_htx ; if not valid, error (jump) +; fetch symbol chain from indicated hash table bucket + popm ; restore pointer to environment object + add SI,AX ; env-ptr += hash-value * 3 + shl AX,1 + add SI,AX + LoadPage ES,BX ; load environment page's paragraph address +;;; mov ES,pagetabl+[BX] ; load environment page's paragraph address + mov BL,ES:[SI].env_npag ; load pointer to hash chain + cmp BL,0 ; is chain empty? + je srch_nfx ; if chain is empty, symbol not found (jump) + mov SI,ES:[SI].env_ndis + LoadPage ES,BX +;;; mov ES,pagetabl+[BX] + mov DX,lcl_page ; restore symbol pointer into DX:AX + mov AX,lcl_disp + call lookup ; search for symbol in linked list + mov SI,DI ; put pointer returned in BX:SI + ret ; return to caller +; ***error-- symbol operand wasn't a symbol*** +srch_htx: add SP,WORDINCR*2 ; drop saved arguments off stack + xor BX,BX ; return a nil pointer +srch_nfx: xor SI,SI + ret +srch_env endp + +;************************************************************************ +;* Symbol Binding Routine * +;* * +;* Purpose: Lattice C callable routine to return the bind a value to * +;* a symbol in a given environment. * +;* * +;* Calling Sequence: sym_bind(symbol, value, environment) * +;* where symbol - register containing the symbol * +;* pointer * +;* value - register containing the value to * +;* be assigned * +;* environment - register containing a pointer to * +;* the environment in which the * +;* binding is to take place * +;************************************************************************ +bind_arg struc + dw ? ; caller's BP + dw ? ; caller's ES + dw ? ; return address +bnd_sym dw ? ; address of symbol register +bnd_val dw ? ; address of value register +bnd_env dw ? ; address of environment register +bind_arg ends + + public sym_bind +bind_it proc near + push ES ; save the caller's ES register + push BP ; save the caller's BP register + mov BP,SP ; establish addressability for local data + jmp sb_new ; bind symbol in current environment + +sym_bind: push ES ; save the caller's ES register + push BP ; save the caller's BP register + mov BP,SP ; establish addressability for local data + +; see if symbol is already present in the environment + mov BX,[BP].bnd_sym ; load address of symbol register + mov CX,[BX].C_page ; load symbol pointer into CX:DX + mov DX,[BX].C_disp + mov BX,[BP].bnd_env ; load address of environment register + mov SI,[BX].C_disp ; load environment pointer into BX:SI + mov BX,[BX].C_page + call srch_all ; search the environment for the symbol + cmp BL,0 ; was the symbol found in the environment? + je sb_new ; if symbol not found, jump +; store the value into the cdr field of the returned value cell + LoadPage ES,BX ; load value cell's paragraph address +;;; mov ES,pagetabl+[BX] ; load value cell's paragraph address + mov BX,[BP].bnd_val ; load address of value register + mov AL,byte ptr [BX].C_page ; copy value from value register + mov ES:[SI].cdr_page,AL ; into the cdr field of the value cell + mov AX,[BX].C_disp + mov ES:[SI].cdr,AX + jmp sb_ret ; return to caller + +; fetch pointer to environment-- decide format of said +sb_new: mov SI,[BP].bnd_env + mov BX,[SI].C_page + mov SI,[SI].C_disp + LoadPage ES,BX +;;; mov ES,pagetabl+[BX] + cmp ES:[SI].env_len,ENV_SIZE + jne sb_ht +; +; bind symbol to "rib" format environment +; +; cons(env[name], symbol, env[name]) + mov AL,ES:[SI].env_npag ; copy name list chain from environment + mov byte ptr tmp_page,AL ; object to tmp_reg + mov AX,ES:[SI].env_ndis + mov tmp_disp,AX + mov AX,offset tmp_reg + pushm ; push arguments to "cons" + call cons ; cons symbol to front of name list + mov BX,[BP].bnd_env ; reload pointer to environment object + mov SI,[BX].C_disp ; (it may have been relocated during the + mov BX,[BX].C_page ; consing operation) + LoadPage ES,BX +;;; mov ES,pagetabl+[BX] ; + mov AL,byte ptr tmp_page ; update name list pointer in the + mov ES:[SI].env_npag,AL ; environment object + mov AX,tmp_disp + mov ES:[SI].env_ndis,AX +; cons(env[value], env[value], value) + mov AL,ES:[SI].env_vpag ; copy value list chain from environment + mov byte ptr tmp_page,AL ; object to tmp_reg + mov AX,ES:[SI].env_vdis + mov tmp_disp,AX + mov AX,offset tmp_reg + pushm <[BP].bnd_val,AX,AX> ; push arguments to "cons" + call cons ; cons value to front of value list + mov BX,[BP].bnd_env ; reload pointer to environment object + mov SI,[BX].C_disp ; (it may have been relocated during the + mov BX,[BX].C_page ; consing operation) + LoadPage ES,BX +;;; mov ES,pagetabl+[BX] ; + mov AL,byte ptr tmp_page ; update value list pointer in the + mov ES:[SI].env_vpag,AL ; environment object + mov AX,tmp_disp + mov ES:[SI].env_vdis,AX + jmp sb_ret ; return to caller +; +; bind symbol to "hash table" format environment +; +sb_ht: +; cons(tmp_reg, symbol, value) + mov AX,offset tmp_reg ; load address of tmp_reg + mov BX,offset nil_reg ; load address of nil_reg +; Note: we're pushing the arguments for both calls to "cons" in the +; following statement + pushm ; push args to cons + call cons + add SP,3*WORDINCR ; drop the top three arguments from the stack +; cons(tmp_reg, tmp_reg, nil_reg) + call cons +; obtain hash value for the symbol + push [BP].bnd_sym + call sym_hash + mov BX,AX ; multiply hash value by 3 + shl AX,1 + add BX,AX + mov SI,[BP].bnd_env ; load pointer to environment object + add BX,[SI].C_disp ; (which may have been moved during + mov SI,[SI].C_page ; the consing operations) + LoadPage ES,SI +;;; mov ES,pagetabl+[SI] + mov AX,tmp_page ; load pointer to second list cell + mov SI,AX + xchg AL,ES:[BX].env_npag ; swap list header in environment hash + mov DX,tmp_disp ; table with the pointer to the second + mov DI,DX ; list cell + xchg DX,ES:[BX].env_ndis + LoadPage ES,SI ; load pointer to second list cell +;;; mov ES,pagetabl+[SI] ; load pointer to second list cell + mov ES:[DI].cdr_page,AL ; update entry in environment hash table + mov ES:[DI].cdr,DX + +; return to calling procedure +sb_ret: mov SP,BP ; clean up the TIPC's stack + pop BP ; restore caller's BP + pop ES ; restore caller's ES, too + ret ; return to caller +bind_it endp + +;************************************************************************ +;* Symbol Lookup Routine * +;* * +;* Purpose: Lattice C callable routine to return the value bound to * +;* a symbol in a given environment. * +;* * +;* Calling Sequence: sym_bind(symbol, environment) * +;* where symbol - register containing the symbol * +;* pointer * +;* environment - register containing a pointer to * +;* the environment to be searched * +;************************************************************************ +look_arg struc + dw ? ; caller's BP + dw ? ; caller's ES + dw ? ; return address +look_sym dw ? ; address of symbol register +look_env dw ? ; address of environment register +look_arg ends + + public sym_look +sym_look proc near + push ES ; save the caller's ES register + push BP ; save the caller's BP register + mov BP,SP ; establish addressability for local data + +; see if symbol is already present in the environment + mov BX,[BP].look_sym ; load address of symbol register + mov CX,[BX].C_page ; load symbol pointer into CX:DX + mov DX,[BX].C_disp + mov BX,[BP].look_env ; load address of environment register + mov SI,[BX].C_disp ; load environment pointer into BX:SI + mov BX,[BX].C_page + call srch_all ; search the environment for the symbol + xor AX,AX ; set result to false, in case search failed + cmp BL,0 ; was the symbol found in the environment? + je look_ret ; if symbol not found, jump +; return the value in the cdr field in the argument register + LoadPage ES,BX ; load value cell's paragraph address +;;; mov ES,pagetabl+[BX] ; load value cell's paragraph address + mov BX,[BP].look_sym ; load address of register + mov AL,ES:[SI].cdr_page ; copy current binding into the + mov byte ptr [BX].C_page,AL ; argument register + mov AX,ES:[SI].cdr + mov [BX].C_disp,AX + mov AX,1 ; set result to "TRUE" +; return to calling procedure +look_ret: pop BP ; restore caller's BP + pop ES ; restore caller's ES, too + ret ; return to caller +sym_look endp + +;************************************************************************ +;* Symbol Hashing Routine * +;* * +;* Purpose: Lattice C callable routine to return the hash value for * +;* a given symbol. * +;* * +;* Calling Sequence: hash = sym_hash(reg) * +;* reg - register containing symbol pointer * +;* hash - the hash value (if page/disp don't point * +;* to a symbol, -1 is returned) * +;* * +;* Methods Used: The hash value is computed by summing the characters * +;* of the symbol and returning the remainder on division * +;* by the length of the hash table (HT_SIZE). * +;* * +;* Note: This routine must return the same hash value as the routine * +;* "hash" in SUPPORT.C. If the hashing algorithm is * +;* changed, it must be changed in both routines. * +;************************************************************************ +sh_args struc + dw ? ; caller's BP + dw ? ; return address +sh_reg dw ? ; symbol pointer register address +sh_args ends + + public sym_hash +sym_hash proc near + push BP ; save caller's BP + mov BP,SP +; Fetch pointer to symbol-- make sure object is a symbol + mov DI,[BP].sh_reg ; load register address + mov BX,[DI].C_page ; load symbol's page number + cmp byte ptr ptype+[BX],SYMTYPE*2 ; is object a symbol? + jne sh_error ; if not a symbol, error (jump) + push ES ; save caller's ES + LoadPage ES,BX ; load symbol page's paragraph address +;;; mov ES,pagetabl+[BX] ; load symbol page's paragraph address + mov SI,[DI].C_disp ; load symbol's displacement +; Fetch hash value from symbol object + xor AH,AH ; clear high order byte of AX + mov AL,ES:[SI].sym_hkey ; fetch hash key +; Return value in TIPC register AX + pop ES ; restore caller's ES +sh_ret: pop BP ; restore caller's BP + ret ; return +; ***error-- input argument wasn't a symbol pointer*** +sh_error: mov AX,-1 ; return a hash value of -1 + jmp short sh_ret ; return invalid hash value +sym_hash endp + +prog ends + end + \ No newline at end of file diff --git a/sexec.asm b/sexec.asm new file mode 100644 index 0000000..d8c6806 --- /dev/null +++ b/sexec.asm @@ -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 + \ No newline at end of file diff --git a/sgcmark.asm b/sgcmark.asm new file mode 100644 index 0000000..535b555 --- /dev/null +++ b/sgcmark.asm @@ -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 ; 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 + mov AX,DS + mov ES,AX + C_call printf + C_call exit + +sum_spac endp + +prog ends + end + + \ No newline at end of file diff --git a/sgcsweep.asm b/sgcsweep.asm new file mode 100644 index 0000000..7b2e3d6 --- /dev/null +++ b/sgcsweep.asm @@ -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 + mov DI,SI ; Record this fact for next iteration + jmp short swppnxt +; Object was not referenced and can be combined with prev free area +swpp010: add ES:[DI].pt_len,DX ; add length into previous free obj + jmp short swppnxt +; Object was referenced +swpp020: and ES:[SI].port_gc,NOT_GC_BI ; clear gc bit + mov DI,-1 ; Remember last object was referenced +; Processing of current object finished-- add length and iterate +swppnxt: add SI,DX ; Increment area pointer by block length + cmp SI,BX ; Last object in block? + jb swpploop ; Branch, if more space + jmp swppfin ; complete processing + +public fix_big +; Restore memory management tables due to release of large page +fix_big label near + mov AX,PAGESIZE ; update page size of large page to + xchg AX,psize+[BX] ; the default page size + LoadPage DX,BX ; load para address of large page +IFDEF EXTMEM + and pagetabl+[BX],0FF00h +ENDIF +IFDEF PROMEM + mov CX,8 ; amount to get to next selector +ELSE + mov CX,PAGESIZE ; CX <- PAGESIZE/16 + shr CX,1 + shr CX,1 + shr CX,1 + shr CX,1 +ENDIF + mov BX,PAGESIZE +fix_lop: sub AX,PAGESIZE ; decrease extended page size by one page + jbe fix_ret ; if all pages fixed, return + add DX,CX ; compute pointer to next physical page + mov SI,DEDPAGES*2 ; initialize page table index +fix_more: push BX + LoadPage BX,SI ; is this the page we're looking for? + cmp DX,BX + pop BX + je fix_fnd ; if so, jump + inc SI ; increment the page table index + inc SI ; twice + cmp SI,NUMPAGES*2 ; more pages? + jl fix_more ; if so, jump + lea BX,m_fix_er ; error-- loop should not exit + push BX + mov AX,DS ; set TIPC register ES for call to + mov ES,AX ; Lattice C routines + C_call print_an ; print error message and exit +fix_fnd: mov psize+[SI],BX ; reset page size to default + mov attrib+[SI],0 ; reset "no memory" bit in attribute table +IFDEF EXTMEM + and pagetabl+[SI],0FF00h ; strip attributes +ENDIF + mov ptype+[SI],FREETYPE*2 ; mark page as free + jmp short fix_lop ; continue to free extended pages +fix_ret: jmp swpret ; all pages released-- return +; Branch table for processing each data type +btable dw swplist ; [0] List cells + dw swpfix ; [1] Fixnums + dw swpflo ; [2] Flonums + dw swpbig ; [3] Bignums + dw swpsym ; [4] Symbols + dw swpstr ; [5] Strings + dw swpary ; [6] Arrays + dw swpcont ; [7] Continuations + dw swpclos ; [8] Closures + dw swpfree ; [9] Free space (unallocated) + dw swpcode ; [10] Code + dw swpref ; [11] Reference cells + dw swpport ; [12] Port data objects + dw swpchar ; [13] Characters + dw swpenv ; [14] Environments + +swpage endp +prog ends + end + + \ No newline at end of file diff --git a/sinterp.arg b/sinterp.arg new file mode 100644 index 0000000..90bdb8d --- /dev/null +++ b/sinterp.arg @@ -0,0 +1,27 @@ +;*************************************** +;* TIPC Scheme '84 Runtime Support * +;* Interpreter Local Data * +;* * +;* (C) Copyright 1984 by Texas * +;* Instruments Incorporated. * +;* All rights reserved. * +;* * +;* Date Written: 2 May 1984 * +;* Last Modification: 7 June 1984 * +;*************************************** +; Arguments and local storage for "sinterp" +sint_arg struc +save_SI dw ? ; place to save the PC ([SI]) +save_ES dw ? ; place to save ES: +save_DI dw ? ; place to save DI +save_AX dw ? ; place to save AX +save_BX dw ? ; place to save BX +save_CX dw ? ; place to save CX +save_DX dw ? ; place to save DX +C_ES dw ? ; ES: needed by C routines +temp_reg dw 2 dup (?) ; temp register +sint_BP dw ? ; caller's BP + dw ? ; return address +cod_ent dw ? ; &entry offset +no_insts dw ? ; number of instructions to interpret +sint_arg ends diff --git a/sinterp.asm b/sinterp.asm new file mode 100644 index 0000000..42c000c --- /dev/null +++ b/sinterp.asm @@ -0,0 +1,3213 @@ +; =====> SINTERP.ASM +;****************************************************************************** +;* TIPC Scheme '84 Runtime Support * +;* Interpreter * +;* * +;* (C) Copyright 1984,1985,1986,1987 by Texas * +;* Instruments Incorporated. * +;* All rights reserved. * +;* * +;* Date Written: 2 May 1984 * +;* Last Modification: * +;* 11 Feb 86 - Replaced support for even? and odd? to reduce code size and * +;* to update error messages. * +;* - Improved error handling for divide,quotient, and remainder. * +;* - Fixed divide by zero error in Remainder function * +;* 21 Oct 86 - added an additional argument to %graphics - dbs * +;* 7 Nov 86 - %graphics accepts negative arguments (for clipping) - rb * +;* 7 Jan 87 - added random I/O - dbs * +;* 10 Feb 87 - added new opcode (186) for read-line - tc * +;* 8 Mar 87 - XLI - rb * +;* 16 Mar 87 - Added dos-err entry point for detection of Dos I/O errors. * +;* 17 Feb 88 - Mods so sinterp will work in protected mode - tc * +;* * Macros in SMMU.MAC allow stores into code segment * +;* * Graphics for pro mode moved to PROIO.ASM * +;* * %ESC function modified to look for sw-int and call * +;* SOFTINT function in PRO2REAL.ASM * +;* * Timer interrupts no longer taken over for pro mode. * +;* Engines work based on # vm instructions executed for pro * +;* mode. Interpreter loop for engines included (eng_next1) * +;* and settimer, rsttimer included here (conditionally of * +;* course). * +;* * +;* * +;****************************************************************************** + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +; The following files are defined in smmu.equ but are split out here so +; that this module will assemble.... + + include schemed.equ + include schemed.ref + include schemed.mac + purge markedp,pushptr,popptr + include smmu.mac + purge %LoadPage,%LoadPage0,%LoadPage1 +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + include sinterp.mac + include sinterp.arg + include pcmake.equ + include stackf.equ ; define stack frame format + +XGROUP group progx +progx segment word public 'progx' + +IFDEF PROMEM + extrn softint:far ; interface for sw_int (see PRO2REAL.ASM) +ELSE + extrn graphit:far ; interface to graphics primitives +ENDIF + extrn str_apnd:far ; substring append support + extrn str_disp:far ; %substring-display support + + +progx ends + +DGROUP group data +data segment word public 'DATA' + assume DS:DGROUP + + extrn page0:word + +; Primary opcode lookup table +op_table dw copy ; 000- load dest,src + dw ld_const ; 001- ld-const dest,constant-number (byte) + dw ld_imm ; 002- ld-imm dest,immed-value (byte) + dw ld_nil ; 003- ld-nil dest + dw PGROUP:ld_local ; 004- ld-local dest,entry-number (byte) + dw PGROUP:ld_lex ; 005- ld-lex dest,entry-no,delta-level + dw PGROUP:ld_env ; 006- ld-env R(dest),C(sym) + dw PGROUP:ld_globl ; 007- ld-global dest,constant-number (byte) + + dw PGROUP:ld_fluid ; 008- ld-fluid dest,constant-number (byte) + dw ld_off_s ; 009- ld-vec-s vect,offset (byte) + dw ld_off_l ; 010- ld-vec-l vect,offset (word) + dw ld_off_r ; 011- ld-vec-r vect,offset (reg) + dw PGROUP:st_local ; 012- st-local src,entry-number (byte) + dw PGROUP:st_lex ; 013- st-lex src,entry-no,delta-level + dw PGROUP:st_env ; 014- st-env R(val),C(sym) + dw PGROUP:st_globl ; 015- st-global src,constant-number (byte) + + dw PGROUP:st_fluid ; 016- st-fluid src,constant-number (byte) + dw st_off_s ; 017- st-vec-s vect,offset (byte),src + dw st_off_l ; 018- st-vec-l vect,offset (word),src + dw st_off_r ; 019- st-vec-r vect,offset (reg),src + dw PGROUP:set_car ; 020- set-car! dest,src + dw PGROUP:set_cdr ; 021- set-cdr! dest,src + dw recompil ; 022- (unused) formerly set-ref! + dw recompil ; 023- (unused) formerly swap-ref! + + dw PGROUP:spop ; 024- pop dest + dw PGROUP:spush ; 025- push src + dw PGROUP:sdrop ; 026- drop count (unsigned byte) + dw PGROUP:ld_globr ; 027- ld-global-r dest,sym + dw recompil ; 028- (unused- formerly push-heap) + dw PGROUP:bind_fl ; 029- bind-fl const,src + dw PGROUP:unbind_f ; 030- unbind_fl count (byte) + dw PGROUP:define ; 031- define! src,const + + dw jmp_shrt ; 032- jmp_s label (byte) + dw jmp_long ; 033- jmp_l label (word) + dw j_nil_s ; 034- jnil_s reg,label (byte) + dw j_nil_l ; 035- jnil_l reg,label (word) + dw j_nnil_s ; 036- jnnil_s reg,label (byte) + dw j_nnil_l ; 037- jnnil_l reg,label (word) + dw j_atm_s ; 038- jatom_s reg,label (byte) + dw j_atm_l ; 039- jatom_l reg,label (word) + + dw j_natm_s ; 040- jnatom_s reg,label (byte) + dw j_natm_l ; 041- jnatom_l reg,label (word) + dw j_eq_s ; 042- jeq_s reg,label (byte) + dw j_eq_l ; 043- jeq_l reg,label (word) + dw j_neq_s ; 044- jneq_s reg,label (byte) + dw j_neq_l ; 045- jneq_l reg,label (word) + dw recompil ; 046- (unused) formerly deref + dw recompil ; 047- (unused) formerly ref + + dw PGROUP:call_lcl ; 048- call lbl,delta-level,delta-heap + dw PGROUP:call_ltr ; 049- call-tr lbl,delta-level,delta-heap + dw PGROUP:call_cc ; 050- call/cc lbl,delta-level,delta-heap + dw PGROUP:cl_cctr ; 051- call/cc-tr lbl delta-level,delta-heap + dw PGROUP:call_clo ; 052- call-cl reg,number-args + dw PGROUP:call_ctr ; 053- call-cl-tr reg,number-args + dw PGROUP:clcc_c ; 054- call/cc-cl reg + dw PGROUP:clcc_ctr ; 055- call/cc-cl-tr reg + + dw PGROUP:apply ; 056- apply-cl reg,arg + dw PGROUP:apply_tr ; 057- apply-cl-tr reg,arg + dw PGROUP:execute ; 058- execute reg + dw PGROUP:s_exit ; 059- exit + dw PGROUP:cr_close ; 060- close dest,label,number-args + dw PGROUP:drop_env ; 061- drop-env count + dw PGROUP:hash_env ; 062- make-hashed-environment + dw PGROUP:ld_fl_r ; 063- ld-fluid-r dest,sym + + dw PGROUP:ld_car ; 064- car dest,src + dw PGROUP:ld_cdr ; 065- cdr dest,src + dw PGROUP:ld_caar ; 066- caar dest,src + dw PGROUP:ld_cadr ; 067- cadr dest,src + dw PGROUP:ld_cdar ; 068- cdar dest,src + dw PGROUP:ld_cddr ; 069- cddr dest,src + dw PGROUP:ld_caaar ; 070- caaar dest,src + dw PGROUP:ld_caadr ; 071- caadr dest,src + + dw PGROUP:ld_cadar ; 072- cadar dest,src + dw PGROUP:ld_caddr ; 073- caddr dest,src + dw PGROUP:ld_cdaar ; 074- cdaar dest,src + dw PGROUP:ld_cdadr ; 075- cdadr dest,src + dw PGROUP:ld_cddar ; 076- cddar dest,src + dw PGROUP:ld_cdddr ; 077- cdddr dest,src + dw PGROUP:ld_caddd ; 078- cadddr dest,src + dw PGROUP:s_cons ; 079- cons dest,car,cdr + + dw add ; 080- add dest,src + dw addi ; 081- add-imm dest,imm (signed byte) + dw sub ; 082- sub dest,src + dw mul ; 083- mul dest,src + dw muli ; 084- mul-imm dest,imm (signed byte) + dw div ; 085- div dest,src + dw divi ; 086- div-imm dest,imm (signed byte) + dw quo ; 087- quotient dest,src **integers only** + + dw modulo ; 088- remainder dest,src + dw PGROUP:ld_car1 ; 089- %car src=dest + dw PGROUP:ld_cdr1 ; 090- %cdr src=dest + dw random ; 091- %random dest + dw lt_p ; 092- < dest,src + dw le_p ; 093- <= dest,src + dw eq_n ; 094- = dest,src + dw gt_p ; 095- > dest,src + + dw ge_p ; 096- >= dest,src + dw ne_p ; 097- <> dest,src + dw maximum ; 098- max dest,src + dw minimum ; 099- min dest,src + dw eq_p ; 100- eq? dest,src + dw eqv_p ; 101- eqv? dest,src + dw equal_p ; 102- equal? dest,src + dw PGROUP:memq ; 103- memq dest,src + + dw PGROUP:memv ; 104- memv dest,src + dw PGROUP:member ; 105- member dest,src + dw reverseb ; 106- reverse! list + dw not_yet ; 107- reverse list + dw PGROUP:assq ; 108- assq obj,list + dw PGROUP:assv ; 109- assv obj,list + dw PGROUP:assoc ; 110- assoc obj,list + dw PGROUP:s_list ; 111- list obj + + dw PGROUP:appendb ; 112- append! list,obj + dw append ; 113- append list,obj + dw not_yet ; 114- delq! obj,list + dw not_yet ; 115- delete! obj,list + dw getprop ; 116- get-prop name,prop + dw putprop ; 117- put-prop name,val,prop + dw proplist ; 118- proplist name + dw remprop ; 119- remprop name,prop + + dw PGROUP:list2 ; 120- list2 dest=src1,src2 + dw not_yet ; 121- list-ref dest=src1,src2 + dw PGROUP:l_tail ; 122- list-tail dest,count + dw not_op ; 123- (unused) + dw not_op ; 124- (unused) + dw b_xor ; 125- bitwise-xor dest=src1,src2 + dw b_and ; 126- bitwise-and dest=src1,src2 + dw b_or ; 127- bitwise-or dest=src1,src2 + + +; Note: the second half of the opcodes are "second class" opcodes, +; in that TIPC register BH will not be zero at the entry to the +; support routine. For the following instructions, BH will +; contain the value one (1). + + dw atom_p ; 128- atom? dest + dw closur_p ; 129- closure? dest + dw code_p ; 130- code? dest + dw contin_p ; 131- continuation? dest + dw even_p ; 132- even? dest + dw float_p ; 133- float? dest + dw PGROUP:fluid_p ; 134- fluid-bound? dest + dw integr_p ; 135- integer? dest + + dw null_p ; 136- null? dest + dw number_p ; 137- number? dest + dw odd_p ; 138- odd? dest + dw pair_p ; 139- pair? dest + dw port_p ; 140- port? dest + dw proc_p ; 141- proc? dest + dw recompil ; 142- (unused) formerly ref? + dw string_p ; 143- string? dest + + dw symbol_p ; 144- symbol? dest + dw vector_p ; 145- vector? dest + dw eq_z_p ; 146- zero? dest + dw lt_z_p ; 147- negative? dest + dw gt_z_p ; 148- positive? dest + dw sabs ; 149- abs dest + dw float ; 150- float dest + dw minus ; 151- minus dest + + dw sfloor ; 152- floor dest + dw sceiling ; 153- ceiling dest + dw struncat ; 154- truncate dest + dw sround ; 155- round dest + dw char_p ; 156- char? dest + dw PGROUP:env_p ; 157- env? dest + dw not_op ; 158- (unused) + dw not_op ; 159- (unused) + + dw asc_char ; 160- asc->char reg + dw char_asc ; 161- char->asc reg + dw recompil ; 162- (unused) formerly gensym + dw not_op ; 163- (unused) + dw not_op ; 164- (unused) + dw slength ; 165- length list + dw lst_pair ; 166- last-pair list + dw substr ; 167- substr str,pos,len + + dw PGROUP:vec_allo ; 168- alloc-vec dest + dw PGROUP:vec_size ; 169- vect-length dest + dw PGROUP:vec_fill ; 170- vect-fill vect,val + dw not_yet ; 171- make-pack-vect len,bits/elem,signed? + dw s_disply ; 172- %substr-display str,start,end,row,wind + dw not_op ; 173- (unused) + dw set_tim ; 174- %start-timer src=ticks + dw rst_tim ; 175- %stop-timer dest=ticks remaining + + dw popen ; 176- open-port filename,mode + dw pclose ; 177- close-port port + dw PGROUP:spprin1 ; 178- prin1 obj,port + dw PGROUP:spprinc ; 179- princ obj,port + dw PGROUP:spprint ; 180- print obj,port + dw PGROUP:spnewlin ; 181- newline port + dw recompil ; 182- (unused) formerly read + dw recompil ; 183- (unused) formerly file-exists? + + dw PGROUP:prt_len ; 184- print-length obj + dw recompil ; 185- (unused) formerly current-column + dw PGROUP:srd_line ; 186- read-line dest=src (src={port}) + dw PGROUP:srd_atom ; 187- read-atom dest=src (src={port}) + dw PGROUP:read_cha ; 188- read-char dest=src + dw PGROUP:trns_chg ; 189- %transcript src + dw PGROUP:rd_ch_rd ; 190- read-char-ready? dest=src + dw sfasl ; 191- fasl string + + dw PGROUP:ch_eq_p ; 192- char= char1,char2 + dw PGROUP:ch_eq_ci ; 193- char-equal? char1,char2 + dw PGROUP:ch_lt_p ; 194- char< char1,char2 + dw PGROUP:ch_lt_ci ; 195- char-less? char1,char2 + dw PGROUP:ch_up ; 196- char-upcase char + dw PGROUP:ch_down ; 197- char-downcase char + dw str_lng ; 198- string-length string + dw PGROUP:st_ref ; 199- string-ref string,index + + dw PGROUP:st_set ; 200- string-set! string,index,char + dw PGROUP:make_str ; 201- make-string length,char + dw PGROUP:str_fill ; 202- string-fill! string,char + dw str2sym ; 203- string->symbol string + dw str2usym ; 204- string->uninterned-symbol string + dw sym2str ; 205- symbol->string symbol + dw srch_nx ; 206- srch-next str,start,end,charset + dw srch_pr ; 207- srch-prev str,start,end,charset + + dw PGROUP:make_win ; 208- make-window label + dw set_w_at ; 209- set-wind-attr wind,attr,value + dw PGROUP:get_wind ; 210- get-wind-attr wind,attr + dw clr_wind ; 211- clear-window wind + dw PGROUP:save_win ; 212- save-window wind + dw PGROUP:rest_win ; 213- restore-wind wind + dw s_append ; 214- %str-append R(d=s1),R(s2),...,R(s7) + dw PGROUP:sgraph ; 215- %graphics R(s1),R(s2),...,R(s7) + + dw sreify ; 216- %reify R(s1=d),R(s2) ;obj,indx + dw PGROUP:mk_env ; 217- mk-env R(d) + dw PGROUP:env_par ; 218- env-par R(d=s1) ; s1=env + dw PGROUP:env_lu ; 219- env-lu R(d=s1),R(s2) ; sym,env + dw PGROUP:def_env ; 220- def-env R(d=s1),R(s2),R(s3) sve + dw PGROUP:push_env ; 221- push-env C(s1) ; s1=list of syms + dw PGROUP:drop_env ; 222- drop-env + dw PGROUP:ld_env ; 223- ld-env R(d),C(s1) ; s1=symbol + + dw PGROUP:st_env ; 224- st-env R(d=s1),C(s2) ; val,sym + dw PGROUP:set_gnv ; 225- set-glob-env! R(s1) ; s1=env + dw sreifyb ; 226- %reify! R(s1),R(s2),R(s3);o,i,v + dw obj_hash ; 227- object-hash R(d=s1) + dw obj_unhs ; 228- object-unhash R(d=s1) + dw reify_s ; 229- reify-stack R(d=s1) + dw reify_sb ; 220- reify-stack! R(s1),R(s2) + dw sfpos ; 231- set-file-position! + + dw s_esc1 ; 232- %esc1 R(d=s1) + dw s_esc2 ; 233- %esc2 R(d=s1),R(s2) + dw s_esc3 ; 234- %esc3 R(d=s1),R(s2),R(s3) + dw s_esc4 ; 235- %esc4 R(d=s1),R(s2),...,R(s4) + dw s_esc5 ; 236- %esc5 R(d=s1),R(s2),...,R(s5) + dw s_esc6 ; 237- %esc6 R(d=s1),R(s2),...,R(s6) + dw s_esc7 ; 238- %esc7 R(d=s1),R(s2),...,R(s7) + dw xesc ; 239- %xesc R(d=s1),R(len), + ; R(arg1),...,R(arg16); + ; all R(argn) are optional + + dw not_op ; 240- (unused) + dw not_op ; 241- (unused) + dw not_op ; 242- (unused) + dw not_op ; 243- (unused) + dw not_op ; 244- (unused) + dw not_op ; 245- (unused) + dw not_op ; 246- (unused) + dw sgc2 ; 247- gc-with-compaction + + dw exit_op ; 248- halt=(exit) [return to MS-DOS] + dw gc ; 249- %garbage-collect + dw ptyme ; 250- %internal-time dest + dw reset ; 251- reset + dw s_reset ; 252- scheme-reset + dw clr_regs ; 253- %clear-registers + dw not_op ; 254- (reserved for escape) + dw debug_op ; 255- %begin-debug + +reset_BP dw 0 ; initial value of BP for reset purposes + +zero_reg dw 0,SPECFIX*2 ; a "register" containing a fixnum 0 +zero_adr dw zero_reg ; the address of "zero_reg" (for pushing) +m_one dw 1 ; a constant "one" (1) +m_zerodv dw ZERO_DIVIDE_ERROR ; error code for division by zero + +m_not_op db "[VM INTERNAL ERROR] Undefined opcode",LF,0 +m_cod_er db "[VM INTERNAL ERROR] %x:%04x isn't a code base",LF,0 +m_not_yt db "[VM INTERNAL ERROR] Feature not implemented",LF,0 +m_recomp db "[VM ERROR encountered!] Object module incompatible with " + db "this Version",LF,"Recompile from Source",LF,0 + +;;;m_il_st db "[VM ERROR encountered!] VECTOR-SET! operand is write " +;;; db "protected",LF,0 +;;;m_deref db "DEREF",0 +m_ld_r db "LD_R",0 +m_st_r db "ST_R",0 +;;;m_setref db "SET_REF!",0 +;;;m_swaprf db "SWAP_REF!",0 +m_revb db "REVERSE!",0 +m_even db "EVEN?",0 +m_odd db "ODD?",0 +m_v_ld db "VECTOR-REF",0 +m_v_st db "VECTOR-SET!",0 +m_DIV db "/",0 +m_MODULO db "REMAINDER",0 +m_QUOTNT db "QUOTIENT",0 +m_VOE dw VECTOR_OFFSET_ERROR ; error number for "offset out of range" +masc_ch db "INTEGER->CHAR",0 +mch_asc db "CHAR->INTEGER",0 +m_bckwrd db "[VM INTERNAL ERROR] sinterp: instruction preceding %x:%04x " + db "set direction flag",LF,0 +m_reg0 db "[VM INTERNAL ERROR] sinterp: instruction preceding %x:%04x " + db "clobbered register",LF,0 +;;;m_bad_st db "[VM INTERNAL ERROR] sinterp: instruction preceding %x:%04x " +;;; db "screwed up the stack",LF,0 +IFNDEF PROMEM +m_graph db "%GRAPHICS",0 +ENDIF +m_esc db "%ESCN",0 + +; XLI errors (numbered from 1, not 0) +xli_err dw 0 ;this spot unused + dw 0,xli_err2 ;other 0's no longer used spots + dw 0,xli_err4,xli_err5,xli_err6 + dw xli_err7,xli_err8,xli_err9,xli_err10,xli_err11,xli_err12 + dw xli_err13,xli_err14,xli_err15,xli_err16 +; XLI fatal errors print via print_and_exit +;xli_err1 db '[VM FATAL ERROR] Unable to determine length of %XESC VM instruction',LF,0 +; XLI normal errors print via sch_err as secondary line to [VM ERROR ...] message +xli_err2 db '[XLI] First argument to XCALL is not string or symbol',0 +;xli_err3 db '[XLI] Improper number of arguments given to XCALL',0 +xli_err4 db '[XLI] An argument to XCALL is invalid',0 +xli_err5 db '[XLI] The return value of XCALL is invalid',0 +xli_err6 db '[XLI] The function requested by XCALL is not available',0 +xli_err7 db '[XLI] Number too large to fit in 32 bits',0 +xli_err8 db '[XLI] Sync error',0 +xli_err9 db '[XLI] Error in releasing memory of external program',0 +xli_err10 db '[XLI] No memory is available for external program',0 +xli_err11 db '[XLI] Error in loading external program',0 +xli_err12 db '[XLI] No more external programs can be loaded',0 +xli_err13 db '[XLI] File to load not found',0 +xli_err14 db '[XLI] Number too large to fit in 16 bits',0 +xli_err15 db '[XLI] Version mismatch',0 +xli_err16 db '[XLI] Error reported by external program',0 + +IFDEF PROMEM +; +; Following definitions are for protected mode engines. They will be +; used in eng_next1, settimer, and rsttimer defined later in this +; module. +; +tickstat db -1 ;status of engine (0=timeout,1=running,-1=none) +lo_time dw ? ;timer ticks (per vm instuction executed) +hi_time dw ? +ENDIF + +data ends + + +PGROUP group prog +prog segment byte public 'PROG' + assume CS:PGROUP + +; Interpreter support routines defined in "scar_cdr.asm" + extrn ld_car:near + extrn ld_cdr:near + extrn ld_car1:near + extrn ld_cdr1:near + extrn ld_caar:near + extrn ld_cadr:near + extrn ld_cdar:near + extrn ld_cddr:near + extrn ld_caaar:near + extrn ld_caadr:near + extrn ld_cadar:near + extrn ld_caddr:near + extrn ld_cdaar:near + extrn ld_cdadr:near + extrn ld_cddar:near + extrn ld_cdddr:near + extrn ld_caddd:near + extrn set_car:near + extrn set_cdr:near + extrn s_cons:near + extrn s_list:near ; (list obj) + extrn list2:near ; (list a b) + extrn appendb:near ; (append! a b) + extrn l_tail:near ; (list-tail list count) + +; Interpreter support routines defined in "sstack.asm" + extrn set_pos:far ; set-file-position! + +; Interpreter support routines defined in "sstack.asm" + extrn spush:near ; push register contents onto Scheme stack + extrn spop:near ; pop into register from Scheme stack + extrn sdrop:near ; drop elements from top of Scheme stack + extrn ld_local:near ; load from local stack frame + extrn st_local:near ; store into local stack frame + extrn ld_lex:near ; load from higher level stack frame + extrn st_lex:near ; store into higher level stack frame + extrn call_lcl:near ; local call + extrn call_ltr:near ; local call, tail recursive + extrn call_clo:near ; call closure object + extrn call_ctr:near ; call closure object, tail recursive + extrn call_cc:near ; local call/cc + extrn cl_cctr:near ; local call/cc, tail recursive + extrn clcc_c:near ; call/cc, closure object + extrn clcc_ctr:near ; call/cc, closure object, tail recursive + extrn apply:near ; apply closure object + extrn apply_tr:near ; apply closure object, tail recursive + extrn execute:near ; execute code block + extrn s_exit:near ; exit procedure + extrn cr_close:near ; create closure + + extrn force_ca:near ; entry point to force call (to debugger) + +; Interpreter support routines defined in "svars.asm" + extrn ld_fluid:near ; load value of fluid variable + extrn ld_fl_r:near ; load value of fluid variable - reg source + extrn st_fluid:near ; store value into fluid variable + extrn bind_fl:near ; bind fluid variable + extrn unbind_f:near ; unbind fluid variables + extrn fluid_p:near ; fluid-bound? predicate + extrn vec_allo:near ; allocate vector + extrn vec_size:near ; vector-size + extrn vec_fill:near ; vector-fill + extrn memq:near ; memq + extrn memv:near ; memv + extrn member:near ; member + extrn assq:near ; assq + extrn assv:near ; assv + extrn assoc:near ; assoc + +; Interpreter support routines defined in "sstring.asm" + extrn ch_eq_p:near ; (char= char1 char2) + extrn ch_eq_ci:near ; (char-equal? char1 char2) + extrn ch_lt_p:near ; (char< char1 char2) + extrn ch_lt_ci:near ; (char-less? char1 char2) + extrn ch_up:near ; (char-upcase char) + extrn ch_down:near ; (char-downcase char) + extrn make_str:near ; (make-string len char) + extrn str_fill:near ; (string-fill! string char) + extrn st_ref:near ; (string-ref string index) + extrn st_set:near ; (string-set! string index char) + +; Interpreter support routines defined in "senv.asm" + extrn env_p:near ; (environment? obj) + extrn mk_env:near ; (make-environment) + extrn env_par:near ; (environment-parent env) + extrn env_lu:near ; (environment-lookup sym env) + extrn def_env:near ; (define symbol value env) + extrn push_env:near ; (push-environment list) + extrn drop_env:near ; (drop-environment) + extrn hash_env:near ; (make-hashed-environment) + extrn ld_env:near ; (load-env symbol) + extrn st_env:near ; (store-env value symbol) + extrn set_gnv:near ; (set-global-env! env) + extrn ld_globl:near ; load value of global variable + extrn ld_globr:near ; load value of global variable - reg source + extrn st_globl:near ; store value into global variable + extrn define:near ; define! value for global variable + +; Interpreter support routines defined in "sobjhash.asm" + extrn obj_hash:near ; (object-hash obj) + extrn obj_unhs:near ; (object-unhash obj) + +; Interpreter support routines defined in "cwindow.asm" + extrn make_win:near ; (make-window label) + extrn get_wind:near ; (get-window-attribute port attribute) + extrn save_win:near ; (window-save-contents port) + extrn rest_win:near ; (window-restore-contents port contents) + extrn trns_chg:near ; (transcript-on "filename") + extrn rd_ch_rd:near ; (read-char-ready? port) + extrn read_cha:near ; (read-char port) + +; Interpreter support routines defined in "cread.asm" + extrn srd_line:near ; (read-line port) + extrn srd_atom:near ; (read-atom port) + +; Interpreter support routines defined in "cprint.asm" + extrn spprin1:near + extrn spprinc:near + extrn spprint:near + extrn spnewlin:near + extrn prt_len:near + +; XLI + extrn xli_xesc:near ; XLI xesc handler +; extrn print_an:near ; fatal errors + +IFDEF PROMEM +; GRAPHICS - protected mode scheme graphics handler in PROIO.ASM + extrn sgraph:near ;Handle %graphics primitives +ENDIF + +; Entry point to force debug mode prior to next VM instruction + public force_de +force_de: mov AX,word ptr CS:trc_forc + STORE_WORD_IN_CS PROG,next1,AX ; Protected Mode Macro + ret + +IFNDEF PROMEM +; Entry point to force a timeout prior to next VM instruction. This +; will be called from the tick routine in STIMER.ASM. Protected +; mode scheme doesn't use this, as it counts vm instructions as +; engine ticks. +; + public force_ti +force_ti: mov AX,word ptr CS:tim_forc + XCHG_WORD_IN_CS PROG,next1,AX ;Protected Mode Macro + STORE_WORD_IN_CS PROG,reset_tim,AX ;Protected Mode Macro + ret +ENDIF + +; Entry point to process shift-break prior to next VM instruction + public shft_brk +dbg_addr dw VM_debug ; address of the variable VM_debug + dw DGROUP ; DGROUP segment address +sbrk_adr dw s_break ; address of the variable s_break +reset_sb dw 0 +shft_brk: push ES ; save the current ES + les SI,dword ptr CS:dbg_addr ; load the long address for VM_debug + mov DI,CS:sbrk_adr ; load address for s_break + inc word ptr ES:[DI] ; and increment shift-break flag + cmp word ptr ES:[SI],0 ; are we in VM_debug mode? + pop ES ; restore ES + jne force_de ; if we're in VM_debug mode, jump + mov AX,word ptr CS:shft_nxt ; else, force a trap to the debugger + cmp AX,word ptr CS:next1 ; Shift-Brk already depressed? + je shft_brt ; if a duplicate request, skip it + XCHG_WORD_IN_CS PROG,next1,AX ; else enter scheme debugger on + STORE_WORD_IN_CS PROG,reset_sb,AX ; next vm instruction +shft_brt: ret ; continue processing + + public run,interp +run proc near + mov AX,word ptr CS:next_go1 ; modify interpreter loop to disable + STORE_WORD_IN_CS PROG,next1,AX ; instruction level trace capability +interp: push BP + sub SP,offset sint_BP + mov BP,SP + mov reset_BP,BP ; save initial value of BP for reset + +; Set up initial interpreter parameters + mov [BP].C_ES,ES + mov SI,[BP].cod_ent ; load address of entry point offset + mov SI,[SI] ; and load PC + mov BX,CB_pag ; load code base page number + cmp ptype+[BX],CODETYPE*2 ; if page doesn't contain code, + jne code_err ; we've got an error + LoadCode ES,BX ; load code page paragraph addr +; mov ES,pagetabl+[BX] ; load code page paragraph addr + mov [BP].save_ES,ES ; and save it off + jmp next ; jump to start of interpreter +; ***error-- invalid code base-- not a code page*** +code_err: ; push the ptr's disp, page no, and + mov AX,offset DGROUP:m_cod_er ; address of message + pushm + C_call printf ; print error message + jmp debug ; begin debug mode + +trc_oops: cld ; clear direction * checking code + lea BX,m_bckwrd ; * (see below) + jmp short trc_err ; * + +trc_reg0: lea BX,m_reg0 +trc_err: mov AX,CB_pag ; R0 not nil-- print error message + corrpage AX + pushm + C_call printf,,Load_ES + restore + jmp debug + +;**bad_stk: +;** lea BX,m_bad_st ; inconsistent runtime stack error +;** jmp short trc_err + +next_tr1: + dec [BP].no_insts ; decrement count of instructions to run + jge next_go ; if not zero, continue decoding + jmp exit ; out of instructions-- return to debugger +next_go1 equ $ +next_go: xor AX,AX ; Clear high order byte of AX + + mov BX,SI ;* These instructions check to make + xor SI,SI ; * sure that the direction flag is set + lodsb ; * in the forward direction. If not, + cmp SI,1 ; * the "lods" in the interpreter will + mov SI,BX ; * decrement the location pointer + jne trc_oops ;* instead of incrementing it. + + cmp reg0_pag,NIL_PAGE*2 ;* + jne trc_reg0 ; * These instructions check to + cmp reg0_dis,NIL_DISP ; * make sure R0 contains nil (by + jne trc_reg0 ;* convention) + + cmp page0,0 ;* + jne trc_reg0 ; * + cmp page0+2,0 ; * Verify that the location for + jne trc_reg0 ; * the null pointer (page 0, offset 0) + cmp page0+4,0 ; * is still (cons '() '()) + jne trc_reg0 ;* + +; Validate the contents of each of the Scheme registers + mov CX,NUM_REGS+4 ; load number of regsiter into CX (counter) +; Note: also checks GNV_reg, FNV_reg, CB_reg, and tmp_reg + mov DI,offset reg0 ; address of register 0 + mov DX,nextpage ; load number of pages allocated +more_reg: mov AX,[DI].C_page ; load page number field of next register + cmp AX,SPECFIX*2 ; does register contain a fixnum? + je off_ok ; if so, skip offset check (jump) + cmp AX,SPECCHAR*2 ; does register contain a character? + je off_ok ; if so, skip offset check (jump) + mov BX,AX ; copy page number (times 2) into BX + ror AX,1 ; divide by 2, LSB to sign position + cmp AX,DX ; is page number too large? + jae trc_reg0 ; if too large or odd, error (jump) + mov AX,[DI].C_disp ; load displacement field from register + cmp AX,psize+[BX] ; is offset too big? + jae trc_reg0 ; if offset too big, error (jump) +off_ok: add DI,size C_ptr ; increment register offset + loop more_reg ; continue testing all registers + +;** Test consistency of Scheme's runtime stack +;** mov BX,FP ; load current stack frame pointer +;** cmp BX,0 +;** je stk_ok +;**more_stk: +;** mov AL,S_stack+[BX] ; load return address code base page number +;** mov DI,AX +;** cmp byte ptr ptype+[DI],CODETYPE*2 ; is this a code block? +;** jne bad_stk ; if not, bad dynamic link +;** cmp byte ptr S_stack+[BX]+6,SPECFIX*2 ; is dynamic link a fixnum? +;** jne bad_stk ; if not, bad dynamic link +;** mov BX,word ptr S_stack+[BX]+7 ; load pointer to caller's FP +;** sub BX,BASE ; inside current stack buffer? +;** ja more_stk ; if so, continue testing (jump) +;**stk_ok: + + xor AX,AX ; clear TIPC register AX + lods byte ptr ES:[SI] ; Fetch next instruction's opcode + mov BX,AX + shl BX,1 ; Multiply opcode by two for use as index + jmp op_table+[BX] + + +trc_go equ $ + jmp short $+(next_trc-next1) ; jump to overwrite "next" for debug +next_trc: jmp next_tr1 + +tim_forc equ $ + jmp short $+(next_tim-next1) ; jump to force debug mode +next_tim: jmp timeout ; Force execution into debug mode + +trc_forc equ $ + jmp short $+(next_dbg-next1) ; jump to force debug mode +next_dbg: jmp debug ; Force execution into debug mode + +shft_nxt equ $ + jmp short $+(next_sb-next1) ; jump to force Scheme debug mode +next_sb : jmp sc_debug ; Force execution into Scheme debug mode + +IFDEF PROMEM +; +; The following code is for use by engines under protected mode scheme. +; We had a problem collecting timer interrupts from AI Architects OSx86, +; so I just implemented a different interpreter loop which decrements +; a timer tick upon each vm instruction. +; +; Note: this code must be within 128 bytes of next1 (below) so that a +; short jump can be performed. + +eng_tick equ $ + jmp short $+(eng_next1-next1) ; jump to engine loop + +eng_next1: + sub lo_time,1 ;decrement engine tick + sbb hi_time,0 ;if not zero + jnz eng_next2 ; continue + cmp lo_time,0 + jnz eng_next2 + mov tickstat,0 ;zero counter, record timeout + jmp timeout ;force timeout condition +eng_next2: + xor ax,ax ;clear high order byte of ax + lods byte ptr es:[si] ;fetch next instruction's opcode + mov bx,ax + shl bx,1 ;make into index + jmp op_table+[bx] ;go execute the vm instruction code +ENDIF + +; +; Following is the main vm interpreter loop. Note that the location at +; next1 can (and will be) code modified to jump into the debugger, a +; trace loop, and a loop for handling engines in protected mode. +; + public next_SP,next_PC,next +next_SP: mov SP,BP ; Restore SP after call +next_PC: les SI,dword ptr [BP].save_SI ; Reload interpreter's PC & ES +next: +next1 equ $ + xor AX,AX ; Clear high order byte of AX + lods byte ptr ES:[SI] ; Fetch next instruction's opcode + mov BX,AX + shl BX,1 ; Multiply opcode by two for use as index + jmp op_table+[BX] ; go execute the vm instruction code + + +; Jump if nil, short JNILS reg,offset +j_nil_s: lods word ptr ES:[SI] ; load operand, offset + mov BL,AL ; copy register number + cmp byte ptr reg0_pag+[BX],0 ; test for null pointer + jne next ; Jump if not nil + mov AL,AH + cbw ; Sign extend short displacement + add SI,AX ; Add jump offset to current PC + jmp next ; Return to interpreter + +; Jump if not nil, short JNNILS reg,offset +j_nnil_s: lods word ptr ES:[SI] ; load operand, offset + mov BL,AL ; copy register number + cmp byte ptr reg0_pag+[BX],0 ; test for null pointer + je next ; Jump if nil + mov AL,AH + cbw ; Sign extend short displacement + add SI,AX ; Add jump offset to current PC + jmp next ; Return to interpreter + +; Jump if atom,short JATOMS reg,offset +j_atm_s: lods word ptr ES:[SI] ; Load register, offset + mov BL,AL ; copy register number to test + test attrib+[BX],ATOM ; test for atom attribute + jz next ; if not atom, return to interpreter + mov AL,AH ; position branch offset and + cbw ; sign extend to 16 bits + add SI,AX ; add jump offset to current PC + jmp next ; return to interpreter + +; Jump if not atom,short JNATOMS reg,offset +j_natm_s: lods word ptr ES:[SI] ; Load register, offset + mov BL,AL ; copy register number to test + test attrib+[BX],ATOM ; test for atom attribute + jnz next ; if atom, return to interpreter + mov AL,AH ; position branch offset and + cbw ; sign extend to 16 bits + add SI,AX ; add jump offset to current PC + jmp next ; return to interpreter + +; Jump if eq?, short JEQS src1,src2,offset +j_eq_s: lods word ptr ES:[SI] ; load registers to compare + mov BL,AH + mov DI,BX + add DI,offset reg0 ; compute address of src2 + mov BL,AL ; copy src1 register number + lods byte ptr ES:[SI] ; load branch displacement, + cbw ; sign extend, + mov CX,AX ; and save it + mov AX,reg0_dis+[BX] + cmp AX,[DI].C_disp ; are displacements eq? + jne next +j_eq_s1: mov AL,byte ptr reg0_pag+[BX] + cmp AL,byte ptr [DI].C_page ; are page numbers eq? + jne j_eq_nxt + add SI,CX ; add offset to current PC +j_eq_nxt: jmp next + +; Jump if not eq?, short JNEQS src1,src2,offset +j_neq_s: lods word ptr ES:[SI] ; load registers to compare + mov BL,AH + mov DI,BX + add DI,offset reg0 ; compute address of src2 + mov BL,AL ; copy src1 register number + lods byte ptr ES:[SI] ; load branch displacement, + cbw ; sign extend, + mov CX,AX ; and save it + mov AX,reg0_dis+[BX] + cmp AX,[DI].C_disp ; are displacements eq? + jne j_neq_s2 +j_neq_s1: mov AL,byte ptr reg0_pag+[BX] + cmp AL,byte ptr [DI].C_page ; are page numbers eq? + je j_neq_s3 +j_neq_s2: add SI,CX ; add offset to current PC +j_neq_s3: jmp next + +; Jump if eq?, long JEQL src1,src2,offset +j_eq_l: lods word ptr ES:[SI] ; load registers to compare + mov BL,AH + mov DI,BX + add DI,offset reg0 ; compute address of src2 + mov BL,AL ; copy src1 register number + lods word ptr ES:[SI] ; load branch displacement + mov CX,AX ; and save same + mov AX,reg0_dis+[BX] + cmp AX,[DI].C_disp ; are displacements eq? + je j_eq_s1 ; if eq?, continue testing + jmp next ; otherwise, back to interpreter + +; Jump if not eq?, long JNEQL src1,src2,offset +j_neq_l: lods word ptr ES:[SI] ; load registers to compare + mov BL,AH + mov DI,BX + add DI,offset reg0 ; compute address of src2 + mov BL,AL ; copy src1 register number + lods word ptr ES:[SI] ; load branch displacement + mov CX,AX ; and save same + mov AX,reg0_dis+[BX] + cmp AX,[DI].C_disp ; are displacements eq? + je j_neq_s1 ; if equal, continue test + add SI,CX ; add offset to current location pointer + jmp next ; back to the interpreter + +; Jump if nil, long JNILL reg,offset +j_nil_l: lods byte ptr ES:[SI] ; Load the register to test + mov BL,AL ; copy register number + lods word ptr ES:[SI] ; load branch offset + cmp byte ptr reg0_pag+[BX],0 ; Test for null pointer + jne j_nil_l1 ; Jump if not nil + add SI,AX ; Add jump offset to current PC +j_nil_l1: jmp next ; Return to interpreter + +; Jump if not nil, long JNNILL reg,offset +j_nnil_l: lods byte ptr ES:[SI] ; Load the register to test + mov BL,AL ; copy register number + lods word ptr ES:[SI] ; load branch offset + cmp byte ptr reg0_pag+[BX],0 ; Test for null pointer + je j_nnil_1 ; if nil, return to interpreter + add SI,AX ; Add jump offset to current PC +j_nnil_1: jmp next ; Return to interpreter + +; Jump if atom,long JATOMS reg,offset +j_atm_l: lods byte ptr ES:[SI] ; Load register to test + mov BL,AL ; copy register number to test + lods word ptr ES:[SI] ; load branch offset + test attrib+[BX],ATOM ; test for atom attribute + jz j_atm_l1 ; if not atom, return to interpreter + add SI,AX ; add jump offset to current PC +j_atm_l1: jmp next ; return to interpreter + +; Jump if not atom,long JNATOMS reg,offset +j_natm_l: lods byte ptr ES:[SI] ; Load register to test + mov BL,AL ; copy register number to test + lods word ptr ES:[SI] ; load branch offset + test attrib+[BX],ATOM ; test for atom attribute + jnz j_natm_1 ; if atom, return to interpreter + add SI,AX ; add jump offset to current PC +j_natm_1: jmp next ; return to interpreter + +; Jump unconditionally, short +jmp_shrt: lods byte ptr ES:[SI] + cbw ; sign extend the byte offset + add SI,AX + jmp next + +; Jump unconditionally, long +jmp_long: lods word ptr ES:[SI] + add SI,AX + jmp next + +; Move register to register: COPY dest,src +copy: lods word ptr ES:[SI] ; load regs, increment PC + mov BL,AH ; copy source register number into + mov DI,BX ; DI (clear high byte) + mov BL,AL ; copy destination register number + mov AX,reg0_dis+[DI] + mov reg0_dis+[BX],AX + mov AL,byte ptr reg0_pag+[DI] + mov byte ptr reg0_pag+[BX],AL + jmp next + +;************************************************************************ +;* AL AH * +;* Load constant from constant's area LD-CONST dest,const * +;* * +;* Purpose: Interpreter support for loading a compile time constant * +;* into a register of the Scheme virtual machine. * +;************************************************************************ +ld_const: lods word ptr ES:[SI] ; load dest reg and constant number + mov BL,AL ; copy destination register number + mov DI,BX ; into TIPC register DI + mov BL,AH ; isolate constant number + mov AX,BX ; BX <- constant number * 3 + shl AX,1 + add BX,AX + add BX,CB_dis ; add displacement to start of code block + mov AL,ES:[BX].cod_cpag + mov byte ptr reg0_pag+[DI],AL + mov AX,ES:[BX].cod_cdis + mov reg0_dis+[DI],AX + jmp next + +;************************************************************************ +;* AL AH * +;* Load immediate value LD-IMM dest,imm * +;* * +;* Purpose: Interpreter support for loading an immediate value * +;* into a register of the Scheme virtual machine. * +;************************************************************************ +ld_imm: lods word ptr ES:[SI] ; load dest reg, immediate value + mov BL,AL ; copy the destination register number + mov AL,AH ; isolate and sign extend the + cbw ; immediate value + sal AX,1 ; clear high order byte of immediate + shr AX,1 ; value, and + mov reg0_dis+[BX],AX ; store it + mov byte ptr reg0_pag+[BX],SPECFIX*2 ; set reg tag=fixnum + jmp next + +;************************************************************************ +;* Load nil ld-nil dest * +;* * +;* Purpose: Scheme interpreter support to load the value "nil" into * +;* a VM register * +;************************************************************************ +ld_nil: lods byte ptr ES:[SI] ; load destination register number + mov BX,AX + xor AX,AX + mov byte ptr reg0_pag+[BX],AL ; store value of 'nil into + mov reg0_dis+[BX],AX ; destination register + jmp next ; back to the interpreter + + +;************************************************************************ +;* Macro Support for Vector Load * +;************************************************************************ +vec_load macro ld_type + local y,z +IFIDN , + mov DX,4 ; record length of this instruction + lods byte ptr ES:[SI] ; load vector pointer/destination reg + mov DI,AX ; copy pointer to TIPC register DI + lods word ptr ES:[SI] ; load fullword offset + jmp short ld_v_go1 ; continue processing +ELSE + lods word ptr ES:[SI] ; load vect pointer, offset operands + mov BL,AL ; copy vector pointer/destination reg + mov DI,BX ; number into TIPC register DI +IFIDN , + mov AL,AH ; convert immediate byte offset to + cbw ; a fullword value + jmp short ld_v_go ; continue processing +ELSE +IFIDN , + mov BL,AH ; copy number of index register + cmp byte ptr reg0_pag+[BX],SPECFIX*2 ; index a fixnum? + jne z ; if not, error (jump) + mov AX,reg0_dis+[BX] ; load immediate value from index register + shl AX,1 ; sign extend 15 bit immediate + sar AX,1 +ld_v_go: mov DX,3 ; record length of this instruction +ld_v_go1: save ; save current location pointer + mov CX,AX ; multiply the index value by 3 + shl AX,1 ; (3 bytes/element) + add AX,CX + jl y + mov BL,byte ptr reg0_pag+[DI] ; load page number for vector ptr + cmp byte ptr ptype+[BX],VECTTYPE*2 ; does it point to a vector? + jne z ; if not, error (jump) + LoadPage ES,BX ; load paragraph address for vector's page +; mov ES,pagetabl+[BX] ; load paragraph address for vector's page + mov SI,reg0_dis+[DI] ; load vector offset + add AX,offset vec_data ; add offset of 1st vector element + cmp AX,ES:[SI].vec_len ; is reference within bounds? + jge y ; if not, error (jump) + add SI,AX ; add index to vector offset + mov AL,ES:[SI].car_page ; copy vector element to destination + mov byte ptr reg0_pag+[DI],AL ; register + mov AX,ES:[SI].car + mov reg0_dis+[DI],AX + jmp next_PC ; return to the interpreter +; ***error-- offset out of bounds*** +y: mov AX,offset m_v_ld +vbad_off: restore ; restore the location pointer + sub SI,DX ; and back it up to start of instruction + pushm ; push LP and "VECTOR-REF/SET!" text as args + C_call disassem,,Load_ES ; disassemble instruction for *irritant* + pushm ; push numeric error parameters + C_call set_nume + restore ; reload next instruction's address + jmp sch_err ; link to Scheme debugger +; ***error-- invalid operand to vector-load instruction*** +z: lea BX,m_v_ld + jmp src_err ; display error message +ELSE + ***error*** bad macro operand +ENDIF +ENDIF +ENDIF + endm + +;************************************************************************ +;* AL AH * +;* Vector Load with short offset LD-VEC-S vect,offset * +;* * +;* Purpose: Scheme interpreter support for vector load instructions * +;* with short offset fields * +;************************************************************************ +ld_off_s: vec_load SHORT + +;************************************************************************ +;* AL AX * +;* Vector Load with long offset LD-VEC-L vect,offset * +;* * +;* Purpose: Scheme interpreter support for vector load instructions * +;* with long offset fields * +;************************************************************************ +ld_off_l: vec_load LONG + +;************************************************************************ +;* AL AH * +;* Vector Load with register offset LD-VEC-R vect,offset * +;* * +;* Purpose: Scheme interpreter support for vector load instructions * +;* with register offset fields * +;************************************************************************ +ld_off_r: vec_load REG + + purge vec_load + +;************************************************************************ +;* Macro Support for Vector Store * +;************************************************************************ +vec_st macro st_type + local x,y,z +IFIDN , + mov [BP].save_DX,5 ; record length of this instruction + lods byte ptr ES:[SI] ; load vector pointer register + mov DI,AX ; copy pointer to TIPC register DI + lods word ptr ES:[SI] ; load fullword offset + jmp short st_v_go1 ; continue processing +ELSE + lods word ptr ES:[SI] ; load vector pointer, offset operand + mov BL,AL ; copy vector pointer register + mov DI,BX ; number into TIPC register DI +IFIDN , + mov AL,AH ; convert immediate byte offset to + cbw ; a fullword value + jmp short st_v_go ; continue processing +ELSE +IFIDN , + mov BL,AH ; copy number of index register + cmp byte ptr reg0_pag+[BX],SPECFIX*2 ; index a fixnum? + jne z ; if not, error (jump) + mov AX,reg0_dis+[BX] ; load immediate value from index register + shl AX,1 ; sign extend 15 bit immediate + sar AX,1 +st_v_go: mov [BP].save_DX,4 +st_v_go1: mov CX,AX ; save index value in TIPC register CX + lods byte ptr ES:[SI] ; load source register number + save ; save current location pointer + xor DX,DX ; save the source register number in + mov DL,AL ; TIPC register DX + mov AX,CX ; multiply the index value by 3 + shl AX,1 ; (3 bytes/element) + add AX,CX + jl y + mov BL,byte ptr reg0_pag+[DI] ; load page number for vector ptr + cmp byte ptr ptype+[BX],VECTTYPE*2 ; does it point to a vector? + jne z ; if not, error (jump) +;;; test attrib+[BX],READONLY ; is vector's page write protected? +;;; jnz x ; if write protected, error (jump) + LoadPage ES,BX ; load paragraph address for vector's page +; mov ES,pagetabl+[BX] ; load paragraph address for vector's page + mov SI,reg0_dis+[DI] ; load vector offset + add AX,offset vec_data ; add in offset of 1st vector element + cmp AX,ES:[SI].vec_len ; is reference within bounds? + jge y ; if not, error (jump) + add SI,AX ; add index to vector offset + mov DI,DX ; copy source regsiter number into DI + mov AL,byte ptr reg0_pag+[DI] ; copy contents of source register + mov ES:[SI].car_page,AL ; into the element of the vector + mov AX,reg0_dis+[DI] + mov ES:[SI].car,AX + jmp next_PC ; return to the interpreter +;;;; ***error-- write protection violation*** +;;;x: error +; ***error-- offset out of bounds*** +y: restore + mov AX,offset m_v_st + jmp vbad_off +; ***error-- invalid operand to vector-load instruction*** +z: lea BX,m_v_st + jmp src_err ; display error message +ELSE + ***error*** bad macro operand +ENDIF +ENDIF +ENDIF + endm + +;************************************************************************ +;* AL AH AL * +;* Vector Store with short offset ST-VEC-S vect,offset,src * +;* * +;* Purpose: Scheme interpreter support for vector store instructions * +;* with short offset fields * +;************************************************************************ +st_off_s: vec_st SHORT + +;************************************************************************ +;* AL AX AL * +;* Vector Store with long offset ST-VEC-L vect,offset,src * +;* * +;* Purpose: Scheme interpreter support for vector store instructions * +;* with long offset fields * +;************************************************************************ +st_off_l: vec_st LONG + +;************************************************************************ +;* AL AH AL * +;* Vector Store with register offset ST-VEC-R vect,offset,src * +;* * +;* Purpose: Scheme interpreter support for vector store instructions * +;* with register offset fields * +;************************************************************************ +st_off_r: vec_st REG + + purge vec_st + + +;;;; Load from reference cell DEREF dest +;;;deref: lods byte ptr ES:[SI] ; fetch operand, increment location pointer +;;; mov DX,ES ; save TIPC register ES +;;; mov BX,AX ; move destination register field and +;;; add BX,offset reg0 ; and compute destination reg address +;;; mov DI,[BX].C_page ; load source reg page number +;;; cmp byte ptr ptype+[DI],REFTYPE*2 ; does page contain ref cells? +;;; jne not_ref ; if not, jump (must be reference type) +;;; mov ES,pagetabl+[DI] ; load page's paragraph address +;;; mov DI,[BX].C_disp ; load source displacement into page +;;; mov AX,ES:[DI].car ; load disp at source location +;;; mov [BX].C_disp,AX ; store into destination register +;;; mov AL,ES:[DI].car_page ; load page number at source location +;;; mov byte ptr [BX].C_page,AL ; store into destination register +;;; mov ES,DX ; restore TIPC register ES (code block para) +;;; jmp next ; branch back to interpreter +;;;; error-- object of ref not a reference cell +;;;not_ref: save ; save current location pointer +;;; lea BX,m_deref +;;; jmp src_err ; display error message + +;;;; Create a reference cell (ref obj) +;;;ref: lods byte ptr ES:[SI] ; load register number +;;; lea BX,[BP].temp_reg ; load address of temp register and +;;; push BX ; push as argument to "alloc_ref_cell" +;;; C_call alloc_re,,Load_ES ; allocate ref cell +;;; mov SP,BP +;;; mov BX,[BP].temp_reg.C_page ; Load page number of ref cell +;;; mov ES,pagetabl+[BX] ; load paragraph address of ref cell page +;;; mov DI,[BP].temp_reg.C_disp ; load the cell's displacement +;;; mov SI,[BP].save_AX ; restore reg number from old AX into SI +;;;; copy pointer to object into newly allocated ref cell-- update dest reg +;;; mov AX,DI ; copy displacement +;;; xchg AX,reg0_dis+[SI] ; load displacement, and +;;; mov ES:[DI].car,AX ; store into new ref cell +;;; mov AX,BX ; copy page number +;;; xchg AX,reg0_pag+[SI] ; load page number, and +;;; mov ES:[DI].car_page,AL ; store it, too +;;; jmp next_PC + +;************************************************************************ +;* AL AH * +;* Set Reference (set_ref! ref val) SETREF ref,val * +;************************************************************************ +;;;set_ref: lods word ptr ES:[SI] ; load src/dest register numbers +;;; save ; save the location pointer +;;; mov BL,AL ; copy dest register number +;;; mov DI,BX +;;; mov SI,reg0_dis+[DI] ; copy displacement of ref cell +;;; mov BL,byte ptr reg0_pag+[DI] ; copy ref cell's page number +;;; cmp byte ptr ptype+[BX],REFTYPE*2 ; it is a ref cell, isn't it? +;;; jne not_strf ; if not, error +;;; mov ES,pagetabl+[BX] ; load paragraph of ref cell's page +;;; mov BL,AH ; copy source register number +;;; mov AX,reg0_dis+[BX] ; load contents of source register and +;;; mov ES:[SI].car,AX ; and copy into ref cell +;;; mov reg0_dis+[DI],AX ; and into destination register +;;; mov AL,byte ptr reg0_pag+[BX] +;;; mov ES:[SI].car_page,AL +;;; mov byte ptr reg0_pag+[DI],AL +;;; jmp next_PC ; return to interpreter +;;;; Error-- destination of set_ref! or swap_ref! not a ref cell +;;;not_strf: error ; display error message + +;************************************************************************ +;* AL AH * +;* Swap Reference (swap_ref! ref val) SWAPREF dest,val * +;************************************************************************ +;;;swap_ref: lods word ptr ES:[SI] ; load src/dest register numbers +;;; save ; save the current location pointer +;;; mov BL,AL ; copy dest register number +;;; mov DI,BX +;;; mov SI,reg0_dis+[DI] ; copy displacement of ref cell +;;; mov BL,byte ptr reg0_pag+[DI] ; copy ref cell's page number +;;; cmp byte ptr ptype+[BX],REFTYPE*2 ; it is a ref cell, isn't it? +;;; jne not_swrf ; if not, error +;;; mov ES,pagetabl+[BX] ; load paragraph of ref cell's page +;;; mov BL,AH ; copy source register number +;;; mov AX,reg0_dis+[BX] ; load contents of source register and +;;; xchg ES:[SI].car,AX ; and exchange with contents of ref +;;; mov reg0_dis+[DI],AX ; cell +;;; mov AL,byte ptr reg0_pag+[BX] +;;; xchg ES:[SI].car_page,AL +;;; mov byte ptr reg0_pag+[DI],AL +;;; jmp next_PC ; return to interpreter +;;;not_swrf: error ; display error message + +; Negation (minus obj) MINUS dest +minus: lods byte ptr ES:[SI] ; load register field + mov DI,AX ; and copy into DI + add DI,offset reg0 ; load address of register + cmp [DI].C_page,SPECFIX*2 ; is this a fixnum? + jne minus_nf ; if not, go out of line + mov AX,[DI].C_disp ; load immediate value + shl AX,1 ; align for sign extension +minusmrg: neg AX ; negate the immediate value + jo minus_ov ; overflow? if so, make bignum + shr AX,1 ; re-align immediate value + mov [DI].C_disp,AX ; store result into register + jmp next ; return to interpreter +; Not a fixnum-- call arithmetic support +minus_nf: mov DX,MINUS_OP ; indicate negation sub-opcode + +; Process unary operation out of line +arith_1: pushm ; push reg addr, sub-opcode + C_call arith1,,Load_ES ; call unary arithmetic support + cmp AX,0 ; was error encountered? + jne arith_1x ; if error, jump + jmp next_SP ; process next instruction +arith_1x: jmp sch_err ; link to Scheme debugger + +minus_ov: mov AX,16384 ;Create result + sub DI,offset reg0 ; Convert register addr back to reg number + +; Fixnum overflow-- convert to bignum +enlrg1: cwd ; Convert to long integer +enlrg2: add DI,offset reg0 ; compute address of destination register + pushm ; push long int, reg addr + C_call enlarge,,Load_ES ; create bignum + jmp next_SP ; process next instruction + +; Support for absolute value (abs n) +sabs: lods byte ptr ES:[SI] ; load destination register number + mov DI,AX + add DI,offset reg0 ; load register address + cmp [DI].C_page,SPECFIX*2 ; Fixnum (immediate)? + jne abs_nf ; if not, go out-of-line + mov AX,[DI].C_disp ; load immediate value + shl AX,1 ; shift to position sign bit + cmp AX,0 ; how's it relate to zero? + jl minusmrg ; if negative, negate + jmp next ; else do nothing +abs_nf: mov DX,ABS_OP ; load absolute value subopcode + jmp arith_1 ; process out of line + +;************************************************************************ +;* Macro support for out-of-line calls to Lattice C * +;************************************************************************ +OTL_R_ = 1 +OTL_RT_ = 1 +OTL_R macro rtn,error_p + local x +IFNDEF rtn + extrn rtn:near +ENDIF + mov DI,offset PGROUP:rtn ; load address of routine +IFIDN , +IF OTL_RT_ +OTL_RT_ = 0 +otlr1t: lods byte ptr ES:[SI] ; load register operand + save ; save the location pointer + add AX,offset reg0 ; compute address of register + push AX ; and push as single argument + mov AX,DS ; set ES to point to the + mov ES,AX ; current data segment + call DI ; call desired routine + cmp AX,0 ; was error detected? + jl x ; if error, jump + jmp next_SP ; return to interpreter +x: jmp sch_err ; link to Scheme debugger +ELSE + jmp otlr1t ; call desired routine +ENDIF +ELSE +IF OTL_R_ +OTL_R_ = 0 +otlr1: lods byte ptr ES:[SI] ; load register operand + save ; save the location pointer + add AX,offset reg0 ; compute address of register + push AX ; and push as single argument + mov AX,DS ; set ES to point to the + mov ES,AX ; current data segment + mov AX,offset PGROUP:next_SP ; push "next_SP" as the + push AX ; return address + jmp DI ; tail recursive call to routine +ELSE + jmp otlr1 ; call desired routine +ENDIF +ENDIF + endm + +OTL_R2_ = 1 +OTL_R2T_ = 1 +OTL_R2 macro rtn,error_p + local x +IFNDEF rtn + extrn rtn:near +ENDIF + mov DI,offset PGROUP:rtn ; load address of routine +IFIDN , +IF OTL_R2T_ +OTL_R2T_ = 0 +otlr2t: lods word ptr ES:[SI] ; load register operand + save ; 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 + pushm ; push register addresses as arguments + mov AX,DS + mov ES,AX + call DI ; call desired routine + cmp AX,0 ; was error detected? + jl x ; if error, jump + jmp next_SP ; return to interpreter +x: jmp sch_err ; link to Scheme debugger +ELSE + jmp otlr2t +ENDIF +ELSE +IF OTL_R2_ +OTL_R2_ = 0 +otlr2: lods word ptr ES:[SI] ; load register operand + save ; 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 + pushm ; push register addresses as arguments + mov AX,DS ; set ES to point to the current data + mov ES,AX ; segment + mov AX,offset PGROUP:next_SP ; push address of "next_SP" as + push AX ; the return address + jmp DI ; tail recursive call to desired routine +ELSE + jmp otlr2 +ENDIF +ENDIF + endm + +OTL_R3_ = 1 +OTL_R3T_ = 1 +OTL_R3 macro rtn,error_p + local x +IFNDEF rtn + extrn rtn:near +ENDIF + mov DI,offset PGROUP:rtn ; load address of routine +IFIDN , +IF OTL_R3T_ +OTL_R3T_ = 0 +otlr3t: lods byte ptr ES:[SI] ; load 1st operand + add AX,offset reg0 ; and compute register address + mov CX,AX + lods word ptr ES:[SI] ; load 2nd and 3rd operands + save ; 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 + pushm ; push register addresses as arguments + mov AX,DS + mov ES,AX + call DI ; call desired routine + cmp AX,0 ; was error detected? + jl x ; if error, jump + jmp next_SP ; return to interpreter +x: jmp sch_err ; link to Scheme debugger +ELSE + jmp otlr3t ; call desired routine +ENDIF +ELSE +IF OTL_R3_ +OTL_R3_ = 0 +otlr3: lods byte ptr ES:[SI] ; load 1st operand + add AX,offset reg0 ; and compute register address + mov CX,AX + lods word ptr ES:[SI] ; load 2nd and 3rd operands + save ; 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 + pushm ; push register addresses as arguments + mov AX,DS + mov ES,AX + mov AX,offset PGROUP:next_SP ; push address of "next_SP" as + push AX ; the return address + jmp DI ; tail recursive call to desired routine +ELSE + jmp otlr3 ; call desired routine +ENDIF +ENDIF + endm + +OTL_R4_ = 1 +OTL_R4T_ = 1 +OTL_R4 macro rtn,error_p + local x +IFNDEF rtn + extrn rtn:near +ENDIF + mov DI,offset PGROUP:rtn ; load address of routine +IFIDN , +IF OTL_R4T_ +OTL_R4T_ = 0 +otlr4t: lods word ptr ES:[SI] ; load 1st and 2nd operands + xor CX,CX + xor DX,DX + mov DL,AL ; copy 1st operand register number + add DX,offset reg0 + mov CL,AH ; copy 2nd operand register number + add CX,offset reg0 + lods word ptr ES:[SI] ; load 3rd and 4th operands + save ; save the location pointer + xor BX,BX + mov BL,AH ; copy 4th operand register number + add BX,offset reg0 ; compute address of register + xor AH,AH + add AX,offset reg0 + pushm ; push register addresses as arguments + mov AX,DS + mov ES,AX + call DI ; call desired routine + cmp AX,0 ; was error detected? + jl x ; if error, jump + jmp next_SP ; return to interpreter +x: jmp sch_err ; link to Scheme debugger +ELSE + jmp otlr4t ; call desired routine +ENDIF +ELSE +IF OTL_R4_ +OTL_R4_ = 0 +otlr4t: lods word ptr ES:[SI] ; load 1st and 2nd operands + xor CX,CX + xor DX,DX + mov DL,AL ; copy 1st operand register number + add DX,offset reg0 + mov CL,AH ; copy 2nd operand register number + add CX,offset reg0 + lods word ptr ES:[SI] ; load 3rd and 4th operands + save ; save the location pointer + xor BX,BX + mov BL,AH ; copy 4th operand register number + add BX,offset reg0 ; compute address of register + xor AH,AH + add AX,offset reg0 + pushm ; push register addresses as arguments + mov AX,DS + mov ES,AX + mov AX,offset PGROUP:next_SP ; push address of "next_SP" as + push AX ; the return address + jmp DI ; tail recursive call to desired routine +ELSE + jmp otlr4 ; call desired routine +ENDIF +ENDIF + endm + +;************************************************************************ +; Convert number to fixnum (toward nearest integer) ROUND reg * +;************************************************************************ +sround: OTL_R round,TEST_RESULT + +;************************************************************************ +; Convert number to fixnum (toward - infinity) FLOOR reg * +;************************************************************************ +sfloor: OTL_R floor,TEST_RESULT + +;************************************************************************ +; Convert number to fixnum (toward + infinity) CEILING reg * +;************************************************************************ +sceiling: OTL_R ceiling,TEST_RESULT + +;************************************************************************ +; Convert number to fixnum (toward zero) TRUNCATE reg * +;************************************************************************ +struncat: OTL_R truncate,TEST_RESULT + +;************************************************************************ +; Convert number to fixnum FLOAT reg * +;************************************************************************ +float: OTL_R sfloat,TEST_RESULT + +;************************************************************************ +;* Support for string->symbol (string->symbol dest) * +;************************************************************************ +str2sym: OTL_R str_2_sy,TEST_RESULT + +;************************************************************************ +;* string->uninterned-symbol (string->uninterned-symbol dest) * +;************************************************************************ +str2usym: OTL_R str_2_us,TEST_RESULT + +;************************************************************************ +;* Support for symbol->string (symbol->string dest) * +;************************************************************************ +sym2str: OTL_R sym_2_st,TEST_RESULT + +;************************************************************************ +;* Support for fast load (fasl filename) * +;************************************************************************ +sfasl: OTL_R fasl,TEST_RESULT + +;;;;************************************************************************ +;;;;* Support for unique symbol generation (gensym sym) * +;;;;************************************************************************ +;;;gensym: OTL_R sgensym + +;************************************************************************ +;* Support for prop-list (prop-list name) * +;************************************************************************ +proplist: OTL_R prop_lis,TEST_RESULT + +;************************************************************************ +;* Support for random (random seed) * +;************************************************************************ +random: OTL_R srandom + +;;;;************************************************************************ +;;;;* Support for current-column (current-column dest) * +;;;;************************************************************************ +;;;curr_clm: OTL_R current_ + +;;;;************************************************************************ +;;;;* Support for line-length (line-length dest) * +;;;;************************************************************************ +;;;line_lng: OTL_R line_len + +;;;;************************************************************************ +;;;;* Support for set-line-length! (set-line-length! len) * +;;;;************************************************************************ +;;;set_lng: OTL_R set_line + +;;;;************************************************************************ +;;;;* Support for file-exists? (file-exists? string) * +;;;;************************************************************************ +;;;file_ex: OTL_R file_exi + +;************************************************************************ +;* Support for %internal-time (%internal-time dest) * +;************************************************************************ +ptyme: OTL_R ptime + +;************************************************************************ +;* Support for make-window (make-window dest) * +;************************************************************************ +;;;mk_wind: OTL_R make_win,TEST_RESULT + +;************************************************************************ +;* Support for clear-window (clear-window dest) * +;************************************************************************ +clr_wind: OTL_R clear_wi,TEST_RESULT + +;************************************************************************ +;* Support for read-char (read-char dest) * +;************************************************************************ +;;;readch: OTL_R read_cha,TEST_RESULT + +;************************************************************************ +;* Support for close-port (close-port port) * +;************************************************************************ +pclose: OTL_R spclose,TEST_RESULT + +;************************************************************************ +;* Support for newline (newline port) * +;************************************************************************ +;;;pnewlin: OTL_R spnewlin,TEST_RESULT + +;************************************************************************ +;* Support for read (read port) * +;************************************************************************ +;;;pread: OTL_R spread,TEST_RESULT + +;************************************************************************ +;* Support for print-length (print-length obj) * +;************************************************************************ +;;;prt_len_: OTL_R prt_len + +;************************************************************************ +;* Support for %transcript (%transcript port/nil) * +;************************************************************************ +;;;transcrip: OTL_R trns_chg + +;************************************************************************ +;* Support for read-char-ready? (read-char-ready? port) * +;************************************************************************ +;;;read_cr: OTL_R rd_ch_rd,TEST_RESULT + +;************************************************************************ +;* Support for save-window (save-window-contents port) * +;************************************************************************ +;;;sav_wind: OTL_R save_win,TEST_RESULT + +;************************************************************************ +;* Support for read-atom (read-atom port)* +;************************************************************************ +;;;read_at: OTL_R srd_atom,TEST_RESULT + +;************************************************************************ +;* Support for %start-timer (%start-timer #-ticks) * +;************************************************************************ +set_tim: OTL_R cset_tim,TEST_RESULT + +;************************************************************************ +;* Support for %stop-timer (%stop-timer) * +;************************************************************************ +rst_tim: OTL_R crst_tim,TEST_RESULT + +;************************************************************************ +;* Support for STRING-LENGTH (STRING-LENGTH STRING) * +;************************************************************************ +str_lng: OTL_R st_len,TEST_RESULT + +;************************************************************************ +;* Support for REIFY-STACK (REIFY-STACK index) * +;************************************************************************ +reify_s: OTL_R reif_stk,TEST_RESULT + +;************************************************************************ +;* Support for princ (princ obj {port}) * +;************************************************************************ +;;;pprinc: OTL_R2 spprinc,TEST_RESULT + +;************************************************************************ +;* Support for get-prop (get-prop name prop) * +;************************************************************************ +getprop: OTL_R2 get_prop + +;************************************************************************ +;* Support for rem-prop (rem-prop name prop) * +;************************************************************************ +remprop: OTL_R2 rem_prop + +;************************************************************************ +;* Support for get-window-attribute (get-window-attribute wind attr) * +;************************************************************************ +;;;get_w_at: OTL_R2 get_wind,TEST_RESULT + +;************************************************************************ +;* Support for open-port (open port mode) * +;************************************************************************ +popen: OTL_R2 spopen,TEST_RESULT + +;************************************************************************ +;* Support for prin1 (prin1 obj {port}) * +;************************************************************************ +;;;pprin1: OTL_R2 spprin1,TEST_RESULT + +;************************************************************************ +;* Support for print (print obj {port}) * +;************************************************************************ +;;;pprint: OTL_R2 spprint,TEST_RESULT + +;************************************************************************ +;* Support for restore-window (restore-window-contents port data) * +;************************************************************************ +;;;res_wind: OTL_R2 rest_win,TEST_RESULT + +;************************************************************************ +;* Support for REIFY-STACK! (REIFY-STACK index value) * +;************************************************************************ +reify_sb: OTL_R2 reif_stb,TEST_RESULT + +;************************************************************************ +;* Support for APPEND (APPEND list obj) * +;************************************************************************ +append: OTL_R2 sappend,TEST_RESULT + +;************************************************************************ +;* Support for put-prop (put-prop name value prop) * +;************************************************************************ +putprop: OTL_R3 put_prop,TEST_RESULT + +;************************************************************************ +;* Substring (substring string position length) SUBSTR str,pos,len * +;************************************************************************ +substr: OTL_R3 ssubstr,TEST_RESULT + +;************************************************************************ +;* Support for set-window-attr (get-window-attribute wind attr val) * +;************************************************************************ +set_w_at: OTL_R3 set_wind,TEST_RESULT + +;************************************************************************ +;* Support for subset-find-next-char-in-set (... str start end charset) * +;************************************************************************ +srch_nx: OTL_R4 srch_nxt,TEST_RESULT + +;************************************************************************ +;* Support for subset-find-prev-char-in-set (... str start end charset) * +;************************************************************************ +srch_pr: OTL_R4 srch_prv,TEST_RESULT + +;************************************************************************ +;* Interface to set file position (set-file-position! port chunk# bytes) +;************************************************************************ + +sfpos: OTL_R3 set_pos,TEST_RESULT + + purge OTL_R,OTL_R2,OTL_R3,OTL_R4 + +;************************************************************************ +;* AL AH AL * +;* Support for "reification" (%reify obj index) * +;* (%reify! obj index val) * +;************************************************************************ +sreifyb: mov CX,1 ; set flag for "store" operation + jmp short sreif_10 ; skip next instruction +sreify: xor CX,CX ; set flag for "load" operation +sreif_10: lods word ptr ES:[SI] ; load obj,index operand register numbers + xor BX,BX + mov BL,AL ; copy obj's register number and + lea DI,reg0+[BX] ; compute obj register's address + mov BL,AH ; copy index's register number and + add BX,offset reg0 ; compute index register's address + cmp CX,0 ; is this a load or a store? + je sreif_20 ; if a load, jump + xor AX,AX + lods byte ptr ES:[SI] ; load value register number and + add AX,offset reg0 ; compute value register's address + push AX ; push value reg as argument +sreif_20: pushm ; push index reg, obj reg, direction + C_call reify,,Load_ES ; call: reify(dir,obj,index{,val}); + cmp AX,0 ; test result of reification request + jne sreif_30 ; if error, jump + jmp next_SP ; return to interpreter +; ***error-- error status returned from reify call*** +sreif_30: restore ; reload the location pointer + jmp sch_err ; link to Scheme debugger + +;************************************************************************ +;* Macro definition - Interpreter support for binary operations * +;* * +;* Purpose: To generate interpreter support for operations of the * +;* form: * +;* OP dest,src * +;* where: * +;* destination reg <- destination reg OP source reg * +;************************************************************************ +bin_op macro operation + local label1,label2,label3,label4 + lods word ptr ES:[SI] ; load destination/source register numbers + mov BL,AL ; copy destination reg number to + mov DI,BX ; register DI + mov AL,byte ptr reg0_pag+[DI] ; test to see in destination's + cmp AL,SPECFIX*2 ; page contains fixnums + jne label1 ; if not, process out of line (jump) + mov BL,AH ; copy source register number + cmp AL,byte ptr reg0_pag+[BX] ; is second operand also a fixnum? + jne label1 ; if not, process out of line (jump) + mov BX,reg0_dis+[BX] ; load source (second) operand + mov AX,reg0_dis+[DI] ; load destination (first) operand + shl AX,1 ; adjust sign bits of both + shl BX,1 ; operands +IFIDN , + add AX,BX ; add the two operands + jo add_ov ; overflow? if so, convert to bignum (jump) +ELSE +IFIDN , + sub AX,BX ; subtract the two operands + jo sub_ov ; overflow? if so, convert to bignum (jump) +ELSE +IFIDN , + sar AX,1 ; divide first operand by 2 + imul BX ; multiply the two operands + jo mul_ov ; overflow? if so, convert to bignum (jump) +ELSE +IFIDN ,
+ cmp BX,0 ; is the divisor zero? + je zero_div ; if so, error + cwd ; convert dividend to a doubleword + idiv BX ; divide the two operands + cmp DX,0 ; is remainder zero? + jne div_frac ; if so, return flonum result (jump) + shl AX,1 ; clear high order bit of result +ELSE +IFIDN , + cmp BX,0 ; is the divisor zero? + je zero_dvq ; if so, error + cwd ; convert dividend to a doubleword + idiv BX ; divide the two operands + shl AX,1 ; clear high order bit of result +ELSE +IFIDN , + cmp BX,0 ; is the divisor zero? + je zero_dvm ; if so, error (jump) + cwd ; convert dividend to a doubleword + idiv BX ; divide the two operands (gives remainder) + mov AX,DX ; copy remainder to AX +ELSE +IFIDN , + cmp AX,BX ; compare the two operands + jge max_done ; if destination operand biggest, jump + mov AX,BX ; copy the source operand to AX +ELSE +IFIDN , + cmp AX,BX ; compare the two operands + jle max_done ; if destination operand smallest, jump + mov AX,BX ; copy the source operand to AX +ELSE +IFIDN , + xor AX,BX ; xor the two operands +ELSE +IFIDN , + and AX,BX ; and the two operands +ELSE +IFIDN , + or AX,BX ; ior the two operands +ELSE + ***error*** ; undefined instruction +ENDIF +ENDIF +ENDIF +ENDIF +ENDIF +ENDIF +ENDIF +ENDIF +ENDIF +ENDIF +ENDIF + shr AX,1 ; convert result to 15 bit value + mov reg0_dis+[DI],AX ; store result into destination register + jmp next ; return to the interpreter +IFIDN , +label1: mov DX,ADD_OP ; load operation type +; General arithmetic support for non-interget binary arithmetic operations +; Registers at this point: AH - source register number +; BH - (zero) +; DX - arithmetic sub-opcode (operation type) +; DI - destination register number +bin_ool: mov BL,AH ; copy source register number + add BX,offset reg0 ; compute source register's address + add DI,offset reg0 ; compute destination register's address + pushm ; push arguments on TIPC's stack + C_call arith2,,load_ES ; process the non-integer operation + cmp AX,0 ; error encountered? + jne label4 ; if error detected, jump + jmp next_SP ; return to the interpreter +label4: jmp sch_err ; link to Scheme debugger +ELSE +IFIDN , +label1: mov DX,GE_OP ; load operation type +max_ool: mov BL,AH ; copy source register number + add BX,offset reg0 ; compute source register's address + add DI,offset reg0 ; compute destination register's address + pushm ; push arguments on TIPC's stack + C_call arith2,,load_ES ; process the non-integer operation + cmp AX,0 ; what was the result of the comparison? + jl label3 ; if error detected, jump + jne label2 ; jump, if correct value already in dest reg + restore ; restore register addresses + mov AX,[BX].C_disp ; copy source operand into the destination + mov [DI].C_disp,AX ; register + mov AL,byte ptr [BX].C_page + mov byte ptr [DI].C_page,AL +label2: jmp next_SP ; return to the interpreter +label3: jmp sch_err ; link to Scheme debugger +ELSE +IFIDN , +label1: mov DX,LE_OP ; load operation type + jmp max_ool ; process non-integer comparison out of line +ELSE +label1: mov DX,operation&_OP ; load operation type + jmp bin_ool ; process non-integer operation out of line +ENDIF +ENDIF +ENDIF + endm + + +;************************************************************************ +; Addition (+ obj1 obj2) ADD dest,src * +;************************************************************************ +add: bin_op ADD +sub_ov: cmc ; complement the carry bit for subtract +add_ov: rcr AX,1 ; Shift in sign bit + jmp enlrg1 ; convert to bignum + +;************************************************************************ +;* Subtraction (- obj1 obj2) SUB dest,src * +;************************************************************************ +sub: bin_op SUB + +;************************************************************************ +;* Multiplication (* obj1 obj2) MUL dest,src * +;************************************************************************ +mul: bin_op MUL +mul_ov: sar DX,1 ;Divide product by 2 + rcr AX,1 + jmp enlrg2 ;Convert to bignum + +;************************************************************************ +;* Division (/ obj1 obj2) DIV dest,src * +;************************************************************************ +div: bin_op DIV +; ***Error-- Division by Zero*** +zero_div: mov BX,offset m_DIV ; load text for "\" +zd_010: sub SI,3 ; back up location pointer to start of inst. + pushm ; push inst addr, function name + C_call disassem,,Load_ES ; "disassemble" the instruction + pushm ; push irritant,div code,no restart + C_call set_nume ; set_numeric_error(1,ZERO_DIV,tmp_reg) + restore ; load restart address (not used) + jmp sch_err ; link to Scheme debugger +; ***Fractional Result from Division-- Convert to Flonum*** +div_frac: add DI,offset reg0 ; compute destination register address + push DI ; and push as argument to "sfloat" + C_call sfloat,,load_ES ; convert destination op to flonum + les SI,dword ptr [BP].save_SI ; restore location pointer + sub SI,2 ; back up the location pointer + xor BX,BX ; clear TIPC register BX + jmp div ; re-execute div in floating point + +;************************************************************************ +;* Integer Division (quotient obj1 obj2) QUOTIENT dest,src * +;************************************************************************ +quo: bin_op QUOT +zero_dvq: mov BX,offset m_QUOTNT ; load address of "QUOTIENT" text + jmp zd_010 ; indicate divide by zero + +;************************************************************************ +;* Modulo (mod obj1 obj2) MOD dest,src * +;************************************************************************ +modulo: bin_op MOD +zero_dvm: mov BX,offset m_MODULO ; load address of "REMAINDER" text + jmp zd_010 ; indicate divide by zero + +;************************************************************************ +;* Maximum value (max obj1 obj2) MAX dest,src * +;************************************************************************ +maximum: bin_op MAX +max_done: jmp next ; return to interpreter + +;************************************************************************ +;* Minimum value (min obj1 obj2) MIN dest,src * +;************************************************************************ +minimum: bin_op MIN + +;************************************************************************ +;* (bitwise-xor obj1 obj2) XOR dest,src * +;************************************************************************ +b_xor: bin_op XOR + +;************************************************************************ +;* (bitwise-and obj1 obj2) AND dest,src * +;************************************************************************ +b_and: bin_op AND + +;************************************************************************ +;* (bitwise-or obj1 obj2) OR dest,src * +;************************************************************************ +b_or: bin_op OR + + purge bin_op + +;************************************************************************ +;* Macro definition - Interpreter support for immediate operations * +;* * +;* Purpose: To generate interpreter support for operations of the * +;* form: * +;* OP dest,immediate * +;* where: * +;* destination reg <- destination reg OP immediate * +;************************************************************************ +immed_op macro operation + local label1,label2,label3,label4 + lods word ptr ES:[SI] ; load destination reg/immediate value + mov BL,AL ; copy destination reg number to + mov DI,BX ; register DI + mov AL,AH ; sign extend immediate operand + cbw + cmp byte ptr reg0_pag+[DI],SPECFIX*2 ; dest operand a fixnum? + jne label1 ; if not, process out of line (jump) + mov BX,AX ; move immediate operand to BX + mov AX,reg0_dis+[DI] ; load destination (first) operand + shl AX,1 ; adjust sign bits of both + shl BX,1 ; operands +IFIDN , + add AX,BX ; add the two operands + jo addi_ov ; overflow? if so, convert to bignum (jump) +ELSE +IFIDN , + sub AX,BX ; subtract the two operands + jo addi_ov ; overflow? if so, convert to bignum (jump) +ELSE +IFIDN , + sar AX,1 ; divide first operand by 2 + imul BX ; multiply the two operands + jo muli_ov ; overflow? if so, convert to bignum (jump) +ELSE +IFIDN ,
+ cmp BX,0 ; is the divisor zero? + je zero_dvi ; if so, error + cwd ; convert dividend to a doubleword + idiv BX ; divide the two operands + cmp DX,0 ; is remainder zero? + jne divi_frc ; if not, need flonum result (jump) + shl AX,1 ; clear high order bit of result +ELSE +IFIDN , + cmp BX,0 ; is the divisor zero? + je label2 ; if so, assume result is the dividend + cwd ; convert dividend to a doubleword + idiv BX ; divide the two operands (gives remainder) + mov AX,DX ; copy remainder to AX +label2: +ELSE +IFIDN , + cmp AX,BX ; compare the two operands + jge mxi_done ; if destination operand biggest, jump + mov AX,BX ; copy the source operand to AX +ELSE +IFIDN , + cmp AX,BX ; compare the two operands + jle mxi_done ; if destination operand smallest, jump + mov AX,BX ; copy the source operand to AX +ELSE + ***error*** ; undefined instruction +ENDIF +ENDIF +ENDIF +ENDIF +ENDIF +ENDIF +ENDIF + shr AX,1 ; convert result to 15 bit value + mov reg0_dis+[DI],AX ; store result into destination register + jmp next ; return to the interpreter +IFIDN , +label1: mov DX,ADD_OP ; load operation type +; General arithmetic support for non-integer immediate operations +; Registers at this point: AX - immediate value +; DX - arithmetic sub-opcode (operation type) +; DI - destination register number +bini_ool: add DI,offset reg0 ; compute address of destination register + lea BX,[BP].temp_reg ; load address of temporary register + and AX,07fffH ; mask off sign bit of immediate value + mov [BX].C_disp,AX ; and create a fixnum value in a + mov [BX].C_page,SPECFIX*2 ; temporary register + pushm ; push arguments on TIPC's stack + C_call arith2,,load_ES ; process the non-integer operation + cmp AX,0 ; was error detected? + jne label3 ; if error encountered, jump + jmp next_SP ; return to the interpreter +label3: jmp sch_err ; link to Scheme debugger +ELSE +IFIDN , +label1: mov DX,GE_OP ; load operation type +maxi_ool: add DI,offset reg0 ; compute destination register's address + lea [BX].temp_reg ; load address of temporary register + and AX,07fffH ; mask off sign bit of immediate value + mov [BX].C_disp,AX ; and create a fixnum value in a + mov [BX].C_page,SPECFIX*2 ; temporary register + pushm ; push arguments on TIPC's stack + C_call arith2,,load_ES ; process the non-integer operation + cmp AX,0 ; what was the result of the comparison? + jl label4 ; if error detected, jump + jne label2 ; jump, if correct value already in dest reg + restore ; restore register addresses + mov AX,[BX].C_disp ; copy source operand into the destination + mov [DI].C_disp,AX ; register +label2: jmp next_SP ; return to the interpreter +label4: jmp sch_err ; link to the Scheme debugger +ELSE +IFIDN , +label1: mov DX,LE_OP ; load operation type + jmp maxi_ool ; process non-integer comparison out of line +ELSE +label1: mov DX,operation&_OP ; load operation type + jmp bini_ool ; process non-integer operation out of line +ENDIF +ENDIF +ENDIF + endm + + +;************************************************************************ +;* Add immediate ADDI reg,val * +;************************************************************************ +addi: immed_op ADD +addi_ov: jmp add_ov + + +;************************************************************************ +;* Multiply Immediate MULI reg,val * +;************************************************************************ +muli: immed_op MUL +muli_ov: jmp mul_ov ; convert to bignum + + +;************************************************************************ +;* Divide Immediate DIVI reg,val * +;************************************************************************ +divi: immed_op DIV +zero_dvi: jmp zero_div ; process divide by zero +divi_frc: add DI,offset reg0 ; compute destination register address + push DI ; and push as argument to "sfloat" + C_call sfloat,,load_ES ; convert destination op to flonum + les SI,dword ptr [BP].save_SI ; restore location pointer + sub SI,2 ; back up the location pointer + xor BX,BX ; clear TIPC register BX + jmp divi ; re-execute div immed in floating point + + purge immed_op + +;************************************************************************ +;* Test for (null? obj) NULL? reg * +;************************************************************************ +null_p: lods byte ptr ES:[SI] ; load number of register to test + mov BX,AX ; and copy it into BX + cmp byte ptr reg0_pag+[BX],0 ; is page number 0? + je null_t ; if register nil, jump + xor AX,AX ; set register to nil (test false) + mov byte ptr reg0_pag+[BX],AL + mov reg0_dis+[BX],AX + jmp next +null_t: mov AL,T_PAGE*2 ; set register to 't + mov byte ptr reg0_pag+[BX],AL + mov AX,T_DISP + mov reg0_dis+[BX],AX + jmp next + +;************************************************************************ +;* AL AH * +;* Test for eq? (pointers identical) EQ? dest,src * +;************************************************************************ +eq_p: lods word ptr ES:[SI] ; load source/dest operands + mov BL,AL ; copy destination register number + mov DI,BX ; into TIPC register DI + mov BL,AH ; copy source register number + mov AX,reg0_dis+[BX] ; load page number of source operand + cmp AX,reg0_dis+[DI] ; are the displacements identical? + jne eq_p_no ; if not, jump + mov AL,byte ptr reg0_pag+[BX] ; load src operand's page number + cmp AL,byte ptr reg0_pag+[DI] ; are page numbers identical? + jne eq_p_no ; if not, jump + mov byte ptr reg0_pag+[DI],T_PAGE*2 ; they're "eq"-- set + mov reg0_dis+[DI],T_DISP ; result to 't (true) + jmp next ; return to the interpreter +; pointers are not identical-- set result to nil +eq_p_no: xor AX,AX + mov byte ptr reg0_pag+[DI],AL ; set page number and + mov reg0_dis+[DI],AX ; displacement of result register to nil + jmp next ; return to the interpreter + +;************************************************************************ +;* AL AH * +;* Test for eqv? (pointers identical, or numbers equal) EQ? dest,src * +;************************************************************************ +eqv_p: lods word ptr ES:[SI] ; load source/dest operands + mov BL,AL ; copy destination register number + mov DI,BX ; into TIPC register DI + mov BL,AH ; copy source register number + mov AX,reg0_dis+[BX] ; load page number of source operand + cmp AX,reg0_dis+[DI] ; are the displacements identical? + jne eqv_p_no ; if not, jump + mov AL,byte ptr reg0_pag+[BX] ; load src operand's page number + cmp AL,byte ptr reg0_pag+[DI] ; are page numbers identical? + jne eqv_p_no ; if not, jump + mov byte ptr reg0_pag+[DI],T_PAGE*2 ; they're "eq"-- set + mov reg0_dis+[DI],T_DISP ; result to 't (true) + jmp next ; return to the interpreter +; pointers are not identical-- test for numbers +eqv_p_no: mov AH,BL ; copy source register number and load + mov BL,byte ptr reg0_pag+[BX] ; page number from source reg + test attrib+[BX],FIXNUMS+BIGNUMS+FLONUMS + jz eqv_p_s ; if not a number, jump + mov AX,DI ; copy destination register number and load + mov BL,byte ptr reg0_pag+[DI] ; page number from dest reg + test attrib+[BX],FIXNUMS+BIGNUMS+FLONUMS + jz eqv_p_s ; if not a number, jump + sub SI,2 ; else set ip back to operands + jmp eq_n ; and go test with "=" +eqv_p_s: test attrib+[BX],STRINGS + jz eqv_p_f ; if not a string, operands aren't eqv (jump) + add DI,offset reg0 ; else compute address of destination reg + jmp short equal_p1 ; test using "equal?" +eqv_p_f: xor AX,AX + mov byte ptr reg0_pag+[DI],AL ; set page number and + mov reg0_dis+[DI],AX ; displacement of result register to nil + jmp next ; return to the interpreter + + +;************************************************************************ +;* AL AH * +;* Test equality of s-expressions equal? dest,src* +;* * +;* Purpose: Scheme interpreter support for the testing of "equality" * +;* of two s-expressions. * +;************************************************************************ +equal_p: lods word ptr ES:[SI] ; load operands to be compared + mov BL,AL ; copy destination register number + lea DI,reg0+[BX] ; and load its address +equal_p1: mov BL,AH ; copy source register number + add BX,offset reg0 ; and compute its address, too + pushm ; push arguments onto TIPC's stack + C_call sequal_p,,Load_ES ; call: sequal(&dest,&src) + pop DI ; restore destination register's address + cmp AX,0 ; are operands equal? (return code not zero) + je equal_f ; if not equal, jump + mov byte ptr [DI].C_page,T_PAGE*2 ; set result register + mov [DI].C_disp,T_DISP ; to 't + jmp next_SP ; return to interpreter +equal_f: mov byte ptr [DI].C_page,AL ; set result register to nil + mov [DI].C_disp,AX + jmp next_SP ; return to interpreter + + +;************************************************************************ +;* Macro definition - Support for attribute tests * +;************************************************************************ +attr_mac macro condition + mov DX,condition ; load attribute mask for test +IFIDN , +attr_1: lods byte ptr ES:[SI] ; fetch register to test + mov BX,AX ; copy register number + mov DI,reg0_pag+[BX] ; load page number and +attr_2: mov AX,attrib+[DI] ; and fetch page's attributes + and AX,DX ; test against mask + jnz attr_3 ; if non-zero, test is true (jump) + mov byte ptr reg0_pag+[BX],AL ; set result to nil (0) + mov reg0_dis+[BX],AX + jmp next ; return to interpreter +attr_3: mov AL,T_PAGE*2 ; set result to true + mov byte ptr reg0_pag+[BX],AL + mov AX,T_DISP + mov reg0_dis+[BX],AX + jmp next ; return to interpreter +ELSE + jmp attr_1 ; continue attribute test +ENDIF + endm + + +; Test for (atom? obj) +atom_p: attr_mac ATOM + +; Test for (char? obj) +char_p: attr_mac CHARS + +; Test for (closure? obj) +closur_p: attr_mac CLOSURE + +; Test for (code? obj) +code_p: attr_mac CODE + +; Test for (continuation? obj) +contin_p: attr_mac CONTINU + +; Test for (float? obj) +float_p: attr_mac FLONUMS + +; Test for (integer? obj) +integr_p: attr_mac FIXNUMS+BIGNUMS + +; Test for (number? obj) +number_p: attr_mac NUMBERS + +; Test for (pair? obj) +pair_p: attr_mac LISTCELL + +; Test for (port? obj) +port_p: mov DX,PORTS ; load "port" attribute bit mask + lods byte ptr ES:[SI] ; load instruction's operand + mov BX,AX ; and copy it into BX + mov DI,reg0_pag+[BX] ; load the page number of the operand + cmp DI,CON_PAGE ; is it same page as 'console? + jne attr_2 ; if not, jump + mov AX,reg0_dis+[BX] ; load the displacement of the operand + cmp AX,CON_DISP ; is it 'console? + je attr_3 ; if so, return #!true (jump) + jmp attr_2 ; if not 'console, return #!false + +; Test for (proc? obj) +proc_p: attr_mac CONTINU+CLOSURE + +; Test for (ref? obj) +ref_p: attr_mac REFS + +; Test for (string? obj) +string_p: attr_mac STRINGS + +; Test for (symbol? obj) +symbol_p: attr_mac SYMBOLS + +; Test for (vector? obj) +vector_p: attr_mac VECTORS + + purge attr_mac + +;************************************************************************ +;* Common Support for EVEN?/ODD? * +;* * +;* Input Parameters: ES:[SI] - pointer to even?/odd? instruction's * +;* operand. * +;* DX ------ text address for "EVEN?" or "ODD?" to * +;* be used to create an error message if * +;* an error is detected. * +;* * +;* Output Parameters: Zero Flag (condition code) - 0 => even number * +;* 1 => odd number * +;* * +;* Note: If an invalid operand is detected, this routine exits to the * +;* Scheme debugger. * +;************************************************************************ +eo_which: lods byte ptr ES:[SI] ; load operand to even?/odd? instruction + mov BX,AX ; copy register number to BX + add BX,offset reg0 ; and compute operand register's address + cmp byte ptr [BX].C_page,SPECFIX*2 ; is operand a fixnum? + jne eo_010 ; if not a fixnum, jump + test byte ptr [BX].C_disp,1 ; test LSB of fixnum value + ret ; return to even?/odd? support +; Operand isn't a fixnum-- test for a bignum +eo_010: mov DI,[BX].C_page ; fetch operand's page number + cmp byte ptr ptype+[DI],BIGTYPE*2 ; is operand a bignum? + jne eo_020 ; if not a bignum, error (jump) + mov CX,ES ; save value in ES + LoadPage ES,DI ; load bignum;s paragraph address +; mov ES,pagetabl+[DI] ; load bignum's paragraph address + mov DI,[BX].C_disp ; load bignum's displacement + test byte ptr ES:[DI].big_data,1 ; test LSB of bignum + mov ES,CX ; restore ES register + ret ; return to even?/odd? support +; ***Error-- operand isn't an integer*** +eo_020: pushm ; push operands to "set_src_error" + C_call set_src_,,Load_ES ; call said + jmp sch_err ; link to Scheme debugger + +;************************************************************************ +;* is an integer even? even? dest * +;* * +;* Purpose: Scheme interpreter support for the even? predicate. * +;************************************************************************ +even_p: mov DX,offset m_even ; load text addr, in case of error + call eo_which ; is value even or odd? + jnz eo_false ; if LSB on, jump +eo_true: mov byte ptr [BX].C_page,T_PAGE*2 ; result is #!true + mov [BX].C_disp,T_DISP + jmp next ; return to Scheme interpreter + +;************************************************************************ +;* is an integer odd? odd? dest * +;* * +;* Purpose: Scheme interpreter support for the odd? predicate. * +;************************************************************************ +odd_p: mov DX,offset m_odd ; load text addr, in case of error + call eo_which ; is value even or odd? + jnz eo_true ; if LSB on, jump +eo_false: xor AX,AX ; create a zero value for use as #!false + mov byte ptr [BX].C_page,AL ; result is #!false + mov [BX].C_disp,AX + jmp next ; return to Scheme interpreter + +;************************************************************************ +;* Macro definition - Support for arithmetic testing (cond n1 n2) * +;************************************************************************ +JE_OPCOD = 01110100b +JNE_OPCOD = 01110101b +JL_OPCOD = 01111100b +JGE_OPCOD = 01111101b +JLE_OPCOD = 01111110b +JG_OPCOD = 01111111b +cond_mac macro cond + local x,y,y1,z,pred_T,labelx +IFIDN , + mov DX,NE_OP ; Load "!=" sub-opcode + STORE_BYTE_IN_CS PROG,cnd_jmp,JNE_OPCOD ;Protected Mode Macro + jmp short cnd_go +ELSE +IFIDN , + mov DX,LT_OP ; Load "<" sub-opcode + STORE_BYTE_IN_CS PROG,cnd_jmp,JL_OPCOD ;Protected Mode Macro + jmp short cnd_go +ELSE +IFIDN , + mov DX,GT_OP ; Load ">" sub-opcode + STORE_BYTE_IN_CS PROG,cnd_jmp,JG_OPCOD ;Protected Mode Macro + jmp short cnd_go +ELSE +IFIDN , + mov DX,LE_OP ; Load "<=" sub-opcode + STORE_BYTE_IN_CS PROG,cnd_jmp,JLE_OPCOD ;Protected Mode Macro + jmp short cnd_go +ELSE +IFIDN , + mov DX,GE_OP ; Load ">=" sub-opcode + STORE_BYTE_IN_CS PROG,cnd_jmp,JGE_OPCOD ;Protected Mode Macro + jmp short cnd_go +ELSE +IFIDN , + mov DX,EQ_OP ; Load "=" sub-opcode + STORE_BYTE_IN_CS PROG,cnd_jmp,JE_OPCOD ;Protected Mode Macro +cnd_go: lods word ptr ES:[SI] ; load register numbers to compare + mov BL,AL ; copy n1 register number + mov DI,BX ; into DI (clear high order byte) + cmp byte ptr reg0_pag+[DI],SPECFIX*2 ; is n1 a fixnum? + jne y ; if not, perform comparison out of line + mov BL,AH ; copy n2 register number + cmp byte ptr reg0_pag+[BX],SPECFIX*2; is n2 a fixnum? + jne y1 ; jump if not + mov AX,reg0_dis+[BX] ; load n2's immediate value + mov DX,reg0_dis+[DI] ; load n1's immediate value + shl DX,1 ; adjust immediate values to sign + shl AX,1 ; extend + cmp DX,AX ; compare the two operands +cnd_jmp equ $ + j&cond z ; jump if comparison is satisfied + xor AX,AX ; store '() in destination register + mov byte ptr reg0_pag+[DI],AL + mov reg0_dis+[DI],AX + jmp next ; return to interpreter +z: mov AL,T_PAGE*2 ; store 't in destination register + mov byte ptr reg0_pag+[DI],AL + mov AX,T_DISP + mov reg0_dis+[DI],AX + jmp next ; return to interpreter +; Operand(s) not fixnums-- perform comparison in C routine +y: mov BL,AH +y1: add BX,offset reg0 ; Load address of source register + add DI,offset reg0 ; Load address of destination register + pushm ; Push src, dest, op arguments + C_call arith2,,load_ES ; Call the arithmetic processor + restore + cmp AX,0 ; test result returned from arith2 + jl labelx ; jump if error condition detected + jne pred_T ; jump if comparison is "true" + mov byte ptr [DI].C_page,AL ; store '() into destination register + mov [DI].C_disp,AX + jmp next_SP ; return to interpreter +pred_T: mov byte ptr [DI].C_page,T_PAGE*2 ; set result register to 't + mov [DI].C_disp,T_DISP + jmp next_SP ; return to interpreter +labelx: jmp sch_err ; link to Scheme debugger +ELSE + ***ERROR*** condition not recognized +ENDIF +ENDIF +ENDIF +ENDIF +ENDIF +ENDIF + endm + +; Test for numeric inequality (!= n1 n2) +ne_p: cond_mac ne + +; Test for numeric less than (< n1 n2) +lt_p: cond_mac l + +; Test for numeric greater than (> n1 n2) +gt_p: cond_mac g + +; Test for numeric less than or equal (<= n1 n2) +le_p: cond_mac le + +; Test for numeric greater than or equal (>= n1 n2) +ge_p: cond_mac ge + +; Test for numeric equality (= n1 n2) +eq_n: cond_mac e + + purge cond_mac + +;************************************************************************ +;* Macro definition - Support for arithmetic testing (cond:0 n) * +;************************************************************************ +cnd1_mac macro cond + local x,y,z,cnd1_T,w +IFIDN , + mov DX,NEG_OP ; load negative? comparison subopcode + STORE_BYTE_IN_CS PROG,cnd1_jmp,JL_OPCOD ;Protected Mode Macro + jmp cnd1_go ; process comparison with zero +ELSE +IFIDN , + mov DX,POS_OP ; load positive? comparison subopcode + STORE_BYTE_IN_CS PROG,cnd1_jmp,JG_OPCOD ;Protected Mode Macro + jmp cnd1_go ; process comparison with zero +ELSE +IFIDN , + mov DX,ZERO_OP ; load zero? comparison subopcode + STORE_BYTE_IN_CS PROG,cnd1_jmp,JE_OPCOD ;Protected Mode Macro +cnd1_go: lods byte ptr ES:[SI] ; load number of register to test + mov BX,AX + cmp byte ptr reg0_pag+[BX],SPECFIX*2 ; fixnum (immediate)? + jne y ; if not, go out of line + mov AX,reg0_dis+[BX] ; load immediate value + shl AX,1 ; position sign bit-- set compare code + cmp AX,0 +cnd1_jmp equ $ + j&cond z ; jump if condition satisfied + xor AX,AX ; return '() in destination regsiter + mov byte ptr reg0_pag+[BX],AL + mov reg0_dis+[BX],AX + jmp next ; return to interpreter +z: mov AL,T_PAGE*2 ; return 't in destintation register + mov byte ptr reg0_pag+[BX],AL + mov AX,T_DISP + mov reg0_dis+[BX],AX + jmp next ; return to interpreter +; operand is not a fixnum-- call C routine to perform test +y: add BX,offset reg0 ; load address of destination reg + pushm ; push arguments + C_call arith1,,Load_ES ; link to arithmetic support + restore + cmp AX,0 ; test result returned from "arith1" + jl w ; was error encountered? + jne cnd1_T ; if error, jump + mov byte ptr [BX].C_page,AL ; set result to "nil" + mov [BX].C_disp,AX + jmp next_SP ; return to interpreter +cnd1_T: mov byte ptr [BX].C_page,T_PAGE*2 ; set result to "t" + mov [BX].C_disp,T_DISP + jmp next_SP ; resume interpretation +w: jmp sch_err ; link to Scheme debugger +ELSE + ***ERROR*** invalid comparison type +ENDIF +ENDIF +ENDIF + endm + + +; Test for equality to zero (zero? n) +eq_z_p: cnd1_mac e + +; Test for less than zero (negative? n) +lt_z_p: cnd1_mac l + +; Test for greater than zero (positive? n) +gt_z_p: cnd1_mac g + + purge cnd1_mac + +;************************************************************************ +;* (ascii->char n) ascii->char dest * +;* * +;* Purpose: Scheme interpreter support for the ascii->char function. * +;************************************************************************ +asc_char: lods byte ptr ES:[SI] ; load operand + mov DI,AX ; copy dest register number into DI + cmp byte ptr reg0_pag+[DI],SPECFIX*2 ; is operand a finxum? + jne asc_cher ; if not, error (jump) + and reg0_dis+[DI],00ffH ; "and" off low order eight bits + mov byte ptr reg0_pag+[DI],SPECCHAR*2 ; convert to character + jmp next ; return to interpreter +asc_cher: save ; save the incremented location pointer + lea BX,masc_ch ; load address of "ascii->char" text + jmp src_err ; display invalid operand message + +;************************************************************************ +;* (char->ascii n) char->ascii dest * +;* * +;* Purpose: Scheme interpreter support for the char->ascii function. * +;************************************************************************ +char_asc: lods byte ptr ES:[SI] ; load operand + mov DI,AX ; copy dest register number into DI + cmp byte ptr reg0_pag+[DI],SPECCHAR*2 ; is operand a char? + jne ch_ascer ; if not, error (jump) + mov byte ptr reg0_pag+[DI],SPECFIX*2 ; convert to a fixnum + jmp next ; return to interpreter +ch_ascer: save ; save the incremented location pointer + lea BX,mch_asc ; load address of "char->ascii" text + jmp src_err ; display invalid operand message + +;************************************************************************ +;* Support for list length (length list) * +;************************************************************************ +slength: lods byte ptr ES:[SI] ; load register containing list header + mov BX,AX + save ; save the program counter + lea DI,reg0+[BX] ; load the address of the dest reg + mov BX,[DI].C_page ; load list header from src/dest reg + mov SI,[DI].C_disp + xor AX,AX ; zero the counter + mov CX,SB_CHECK ; load shift-break iteration count +slenloop: cmp BL,NIL_PAGE*2 ; pointer to nil? + je slendone + cmp byte ptr ptype+[BX],LISTTYPE*2 ; list pointer? + jne slendone + inc AX ; increment list cell count + LoadPage ES,BX ; load list cell page para address +; mov ES,pagetabl+[BX] ; load list cell page para address + mov BL,ES:[SI].cdr_page ; load cdr of list cell + mov SI,ES:[SI].cdr + loop slenloop ; cdr down list +; Every so many iterations, check the shift-break key + mov CX,SB_CHECK ; reload the shift-break iteration count + cmp s_break,0 ; has the shift-break key been depressed? + je slenloop ; if no interrupt, continue (jump) +slen_sb: mov AX,2 ; load instruction length = 2 + jmp restart1 ; link to Scheme debugger +slendone: mov byte ptr [DI].C_page,SPECFIX*2 ; return result as a + mov [DI].C_disp,AX ; fixnum (immediate) + jmp next_PC ; return to interpreter + +;************************************************************************ +;* Support for Last-pair (last-pair list) * +;************************************************************************ +lst_pair: lods byte ptr ES:[SI] ; load src/destination register + save ; save the interpreter's program counter + mov DI,AX + mov BX,reg0_pag+[DI] ; load register's page number field + cmp BL,NIL_PAGE*2 ; null pointer? + je lst_exit ; if so, do nothing + cmp byte ptr ptype+[BX],LISTTYPE*2 ; does reg point to list cell? + jne lst_exit ; if not, return it as is + mov SI,reg0_dis+[DI] ; load register's displacement + xor DX,DX + mov CX,SB_CHECK ; load the shift-break iteration count +lst_loop: LoadPage ES,BX ; load page's paragraph address +; mov ES,pagetabl+[BX] ; load page's paragraph address + mov DL,ES:[SI].cdr_page ; load page number of cdr pointer + cmp DL,NIL_PAGE*2 ; cdr nil? + je lst_done ; if so, return current pointer + mov DI,DX ; copy cdr's page number + cmp byte ptr ptype+[DI],LISTTYPE*2 ; cdr points to list cell? + jne lst_done ; if not, we're at the end of our list + mov BL,DL ; follow linked list + mov SI,ES:[SI].cdr + loop lst_loop +; Every so many iterations, check the shift-break key + mov CX,SB_CHECK ; reload the shift-break iteration count + cmp s_break,0 ; has the shift-break key been depressed? + je lst_loop ; if no interrupt, continue (jump) + jmp slen_sb ; link to Scheme debugger +lst_done: mov DI,AX ; re-load destination register number + mov byte ptr reg0_pag+[DI],BL ; store page number + mov reg0_dis+[DI],SI ; store displacement +lst_exit: jmp next_PC ; return to interpreter + +;************************************************************************ +;* (reverse! list) reverse! dest * +;* * +;* Purpose: Scheme interpreter support for the reverse! primitive * +;* * +;* Notes: The following registers are used by this routine: * +;* BL - page number of the current list cell * +;* DI - displacement of the current list cell * +;* ES - paragraph address of the current list cell * +;* Note: ES:[DI] address the current list cell * +;* DL - page number of the previous list cell * +;* AX - displacement of the previous list cell * +;* SI - destination register number * +;************************************************************************ + public reverseb +reverseb: lods byte ptr ES:[SI] ; load operand containing list pointer + save ; preserve the location pointer + mov BL,AL ; copy number of operand register + mov SI,BX ; and put a copy into TIPC register SI + mov BL,byte ptr reg0_pag+[SI] ; load contents of operand register + mov DI,reg0_dis+[SI] ; for initial "current cell" pointer + xor AX,AX ; define previous list cell to be 'nil + xor DX,DX +rev_lp: cmp BL,0 ; end of list (current cell nil)? + je rev_done ; if so, jump + cmp byte ptr ptype+[BX],LISTTYPE*2 ; is current cell a list cell? + jne rev_huh ; if not, error (jump) + LoadPage ES,BX ; load current cell's page address +; mov ES,pagetabl+[BX] ; load current cell's page address + xchg ES:[DI].cdr_page,DL ; swap cdr field with previous cell + xchg ES:[DI].cdr,AX ; pointer + xchg BX,DX ; current cell <-> (cdr current cell) + xchg DI,AX + jmp rev_lp ; continue down list +; list reversal complete-- update destintation register +rev_done: mov byte ptr reg0_pag+[SI],DL ; make destination register point + mov reg0_dis+[SI],AX ; to new head of (reversed) list + jmp next_PC ; return to the interpreter +; ***error-- not a valid linked list*** +rev_huh: mov byte ptr reg0_pag+[SI],DL ; make destination register point + mov reg0_dis+[SI],AX ; to new head of (reversed) list + lea BX,m_revb + jmp src_err ; display error message + + +IFNDEF PROMEM + +; Real mode scheme has graphics linked in with the vm (see graphics.exe), +; and can therefore call it directly. Protected mode scheme must xfer +; to a real mode graphics routine - see PROIO.asm. + +;************************************************************************ +;* Interface to Graphic Primitives (%graphics arg1 ... arg7) * +;************************************************************************ +sgraph: mov CX,7 ; load counter-- seven arguments + xor DX,DX ; set error flag = FALSE + lods byte ptr ES:[SI] ; load first argument + save ; and save as destination register + jmp short sgraph0 +sgraph1: lods byte ptr ES:[SI] ; load next argument +sgraph0: xor AH,AH ; be sure high byte is zero + mov BX,AX ; copy register number to BX + cmp byte ptr reg0_pag+[BX],SPECFIX*2 ; is arg a fixnum? + je sgraph2 ; if arg *is* a fixnum, o.k. (jump) + inc DX ; indicate an invalid argument +sgraph2: mov AX,reg0_dis+[BX] ; expand 15-bit signed int to 16-bit signed int + shl AX,1 + sar AX,1 + push AX ; push 16-bit signed integer +;sgraph2: push reg0_dis+[BX] ; push immediate value of argument + loop sgraph1 ; continue 'til all arguments processed + cmp DX,0 ; any argument errors? + jne sgraph3 ; if errors encountered, jump + save ; save the location pointer +;;; the following two lines are comment out +;;; allow graphics mode for unknown PC machine +;;; cmp PC_MAKE,UNKNOWN ; running on a TIPC? +;;; je not_pc ; if not a TI or IBM brand PC, jump + call graphit ; perform the graphics operation + shl AX,1 ; clear high order bit of result + shr AX,1 ; (convert to immediate value) + mov BX,[BP].save_AX ; reload destintation register number + mov reg0_dis+[BX],AX ; store returned result into destination reg +not_pc: jmp next_SP ; return to interpreter +sgraph3: mov BX,offset m_graph ; load addr of "%graphics" text + jmp src_err ; link to Scheme debugger +ENDIF + +;************************************************************************ +;* Interface to XLI external escape * +;* (%xesc length nargs "name" arg1 ... arg16) where argx is optional * +;* length = # args *to %xesc instruction* * +;************************************************************************ + +xesc: lods byte ptr es:[si] ;get xesc length (variable-length inst.); + ;afterwards, bytecode@ (ES:SI) points + ;at name string + xor ah,ah + mov dx,si ;tempsave bytecode@ to name string + add si,ax ;get ptr to next opcode + dec si + save + mov si,dx ;restore bytecode@ to name string + call xli_xesc ;do xesc + restore ;ES:SI is next opcode @ + cmp ax,0 ;any errors? + jne xesc_10 ;yes, jump + jmp next ;return to interpreter +; normal errors - ax=error number, bx=irritant +xesc_10: + xchg bx,ax ;now ax=irritant,bx=error message + shl bx,1 ;make message# into index + mov bx,xli_err[bx] ;bx => error message + mov cx,1 ;cx = 1, error non-restartable + pushm + mov ax,ds + mov es,ax ;Lattice C needs DS=ES + C_call set_erro ;set up error + jmp sch_err ;jump into debugger + + + +;************************************************************************ +;* ******************************************************************** * +;* * * * +;* * Error routines * * +;* * * * +;* ******************************************************************** * +;************************************************************************ + +IFDEF PROMEM +; +; Engine timer support for protected mode +; +set_args struc + dw ? + dw ? +hi dw ? +lo dw ? +set_args ends + + public settimer +; initialize the timer, set up the engine tick vm loop, and begin +settimer proc near + xor ax,ax ;clear ax + cmp tickstat,-1 ;check for normal run mode + jne no_set ;abort if timeout or engine running + push bp + mov bp,sp + mov ax,[bp].hi ;initialize the timer + mov hi_time,ax + mov ax,[bp].lo + mov lo_time,ax + mov ax,word ptr cs:eng_tick ;ax = handle to engine loop + XCHG_WORD_IN_CS PROG,next1,ax ;int loop now jumps to engine loop + STORE_WORD_IN_CS PROG,reset_tim,ax ;save original value in reset_tim + mov al,1 + mov tickstat,al ;denote engine now running + pop bp +no_set: ret +settimer endp + + public rsttimer +; reset vm loop to original vm loop and return whats left in timer +rsttimer proc near + cmp tickstat,1 ;only if timeout or engine running + ja no_reset ;otherwise, forget it + mov ax,cs:reset_tim ;get inst saved at top of vm loop + STORE_WORD_IN_CS PROG,next1,AX ;reset forced branch at top (next1) + mov tickstat,-1 ;no engine running +no_reset: + mov ax,hi_time ;return time left + mov bx,lo_time + ret ;return +rsttimer endp + +ENDIF + +;************************************************************************ +;* Timer Ran Down * +;************************************************************************ +; Note: the "reset_tim" variable must be in the code segment 'cause +; there's no telling where the DS register points when a +; timer interrupt occurs. +reset_tim dw 0 ; save area for resetting a timer int + public timeout +timeout: +IFNDEF PROMEM + mov AX,CS:reset_tim ; for real mode scheme, reset forced + STORE_WORD_IN_CS PROG,next1,AX ; branch at top of vm loop +ENDIF + C_call rsttimer ; turn off the timer support + mov BX,TIMEOUT_CONDITION ; load "timeout" error code +time_1: xor AX,AX ; set code for "restartable" operation +time_2: mov CX,offset nil_reg ; set *irritant* to 'nil +time_3: pushm ; push arguments to call + C_call set_nume,,Load_ES ; call: set_numeric_error(1,13,nil_reg) + restore ; load next instruction's offset + jmp sch_err ; link to Scheme debugger + +;************************************************************************ +;* Shift-Break Interrupt * +;************************************************************************ +sc_debug: mov AX,CS:reset_sb ; reset forced branch at top + STORE_WORD_IN_CS PROG,next1,AX ; of vm loop + mov s_break,0 ; reset shift-break flag + mov BX,SHIFT_BREAK_CONDITION ; load "shift-break" error code + jmp time_1 ; complete link to Scheme debugger + +;************************************************************************ +;* DOS fatal I/O error process * +;************************************************************************ + public dos_err +dos_err: pop AX ; dump return address + pop AX ; restart/non-restart flag + pop BX ; error code + pop CX ; *irritant* + mov BP,reset_BP ; clean up stack + jmp time_3 ; go invoke Scheme debugger + +;************************************************************************ +;* Error-- Undefined Opcode * +;************************************************************************ +not_op: dec SI ; back up location pointer + save ; and save it + mov BX,offset m_not_op ; load address of error message + mov byte ptr tmp_page,SPECFIX*2 ; convert opcode to a fixnum + mov tmp_disp,AX ; representation for use as "irritant" + mov AX,offset tmp_reg + jmp recom_1 ; jump to common processing point + +;************************************************************************ +;* Error-- Invalid Source Operand * +;************************************************************************ + public src_err +; Note: at this point, BX contains the address for text of failing inst. +src_err: xor AX,AX ; AX <- 0 + pushm ; push string address, 0 + C_call set_src_,,Load_ES ; call: set_src_err(text, 0); + jmp sch_err ; link to Scheme debugger + + +;************************************************************************ +;* Error-- Object Module Not Compatible With Current Revision Level * +;************************************************************************ +recompil: mov AX,offset nil_reg + mov BX,offset m_recomp +recom_1: mov CX,1 + pushm + C_call set_erro ; set the error parameters + restore ; reload the current location pointer + jmp sch_err ; link to Scheme debugger + +;************************************************************************ +;* Error-- Feature Not Yet Implemented * +;************************************************************************ + public not_yet +not_yet: mov BX,offset m_not_yt ; load address of "not yet implemented" + push BX ; and push as argument to printf + dec SI ; back up location pointer + save ; and save it + +; ***general call to printf for message reporting*** + public printf_c +printf_c: C_call printf,,Load_ES ; call printf + mov SP,BP ; dump arguments off stack + restore ; reload location pointer into SI + jmp debug ; begin debug mode + +;************************************************************************ +;* Force Restart of Current Operation * +;************************************************************************ + public restart +restart: pop AX ; discard the return address + pop AX ; fetch instruction length + mov BP,reset_BP ; clean up the TIPC's stack +restart1: sub [BP].save_SI,AX ; back up the instruction pointer + jmp next_SP ; return to the Scheme interpreter + +;************************************************************************ +;* Link to the Scheme Debugger * +;************************************************************************ + public sch_err +sch_err: push SI ; save address of instruction to retry + call force_ca ; force a new stack frame to be built + mov SP,BP ; drop argument from TIPC's stack + mov BX,SPECCODE*2 ; load code base pointer for debug init + mov byte ptr CB_pag,BL + mov CB_dis,0 + LoadCode ES,BX ; load code base's paragraph address +; mov ES,pagetabl+[BX] ; load code base's paragraph address + save ; and save it off + mov SI,ERR_ent ; load error entry point offset + jmp next ; begin link to debugger + +;************************************************************************ +;* Scheme-Reset/Reset * +;* * +;* Purpose: To re-initialize the VM's environment to correct for * +;* some error condition * +;************************************************************************ + public force_re +force_re: mov BP,reset_BP ; reset TIPC stack to its initial state +; Note: control falls through to the scheme-reset code below + +s_reset: C_call scheme_r,,Load_ES ; Adjust fluid environment +; Note: control falls through the reset code below + +reset: C_call reset_fa,,Load_ES ; reset %fasl input data structures + xor AX,AX ; create a value of zero/nil +; set the "previous stack segment" register to nil + mov PREV_pag,AX + mov PREV_dis,AX +; set the current code base to the loader's code page + mov CB_dis,AX + mov CB_pag,SPECCODE*2 +; reset the current stack base to zero and initialize FP + mov BASE,AX + mov FP,AX + mov TOS,SF_OVHD-PTRSIZE +; set the location pointer and code paragraph address + mov BX,SPECCODE*2 + LoadCode ES,BX +; mov ES,pagetabl+[BX] + save + mov SI,RST_ent ; load the new location pointer +; Note: Control falls through the %clear-registers support below + +;************************************************************************ +;* Clear VM registers clear-regs * +;************************************************************************ +clr_regs: save ; save the current location pointer + mov BX,UN_DISP ; load pointer for "unbound" symbol + mov DX,UN_PAGE*2 + mov CX,NUM_REGS-2 ; load iteration count + mov DI,offset reg0+(SIZE C_ptr)*2 ; load address of VM register 2 + mov AX,DS ; set TIPC register ES to point to the + mov ES,AX ; current data section +clr_loop: mov AX,BX ; copy '**unbound** displacement pointer + stosw ; and store it into next register + mov AX,DX ; do likewise for the page number component + stosw ; for the '**unbound** symbol + loop clr_loop ; iterate through the VM's registers + xor AX,AX + mov DI,offset reg0 ; store #!false into R0 and R1 + mov CX,4 +rep stosw + mov tmp_disp,AX ; clear the VM's temporary register, too + mov tmp_page,AX + mov tm2_disp,AX ; clear the VM's temporary register, too + mov tm2_page,AX + jmp next_PC ; return to the interpreter + +;************************************************************************ +;* Escape to user defined assembly language or C Function %escn * +;************************************************************************ +s_esc1: mov CX,1 ; load argument count + jmp short s_escn ; branch to general argument load routine +s_esc2: mov CX,2 ; load argument count + jmp short s_escn ; branch to general argument load routine +s_esc3: mov CX,3 ; load argument count + jmp short s_escn ; branch to general argument load routine +s_esc4: mov CX,4 ; load argument count + jmp short s_escn ; branch to general argument load routine +s_esc5: mov CX,5 ; load argument count + jmp short s_escn ; branch to general argument load routine +s_esc6: mov CX,6 ; load argument count + jmp short s_escn ; branch to general argument load routine + public s_esc7 +s_esc7: mov CX,7 ; load argument count + jmp short s_escn ; branch to general argument load routine + +s_escn: mov DX,CX ; copy count of arguments +s_es_10: xor AX,AX + lods byte ptr ES:[SI] ; load next argument register number + add AX,offset reg0 + push AX + loop s_es_10 ; continue 'til all arguments processed + push DX ; push number of arguments + +IFDEF PROMEM +; +; This is pretty kludgy, but there wasn't time to redo all the %esc +; functions into vm codes, and we need software interrupt to work +; as before. Anyway, sw-int is the only %escape function with seven +; arguments, so lets short circuit here and call the protected mode +; software interrupt code. +; + cmp dx,7 ;are there seven arguments? + jne s_es_12 ; no, can't be sw_int + save ;save off instruction pointer + call softint ;and call the pro mode sw_int routine + cmp ax,0 ;any errors? + je s_es_20 ; no, jump +; errors - ax=error number, bx=msg address, cx=irritant + pushm ;push args to error routine + mov ax,ds + mov es,ax ;Lattice C needs DS=ES + C_call set_erro ;call error routine + restore ;restore instruction pointer + jmp sch_err ;and jump to scheme debugger +ENDIF + +s_es_12: + C_call asm_link,,Load_ES +s_es_13: + cmp AX,0 + je s_es_20 + restore ; restore address of next instruction + mov BX,offset m_esc + jmp src_err ; report some sort of operand error +s_es_20: jmp next_SP ; no error reported; return to interpreter + +;************************************************************************ +;* (%str-append str1 start1 end1 {nil,char,str2} str3 start3 end3) * +;************************************************************************ +s_append: jmp str_apnd ; far jump to substring-append support + +;************************************************************************ +;* (%substring-display str start end row-displacement window) * +;************************************************************************ + public s_disply ; ***temporary*** +s_disply: jmp str_disp ; far jump to substring-display support + +;************************************************************************ +;* Invoke garbage collection gc * +;************************************************************************ +gc: mov byte ptr tmp_page,0 ; clear tmp_reg prior to GC + mov tmp_disp,0 + mov byte ptr tm2_page,0 ; clear tm2_reg prior to GC + mov tm2_disp,0 + C_call garbage,,Load_ES ; call garbage collection driver + jmp next_SP + +;************************************************************************ +;* Invoke garbage collection with compaction gc2 * +;************************************************************************ +sgc2: mov byte ptr tmp_page,0 ; clear tmp_reg prior to GC + mov tmp_disp,0 + mov byte ptr tm2_page,0 ; clear tm2_reg prior to GC + mov tm2_disp,0 + C_call garbage,,Load_ES ; call garbage collection driver + C_call gcsquish + jmp next_SP + +;************************************************************************ +;* Begin Debug %begin-debug * +;************************************************************************ + public debug_op +debug_op: mov VM_debug,1 ; enable VM debugger for (%begin-debug) +debug: + mov AX,word ptr CS:trc_go ; modify interpreter to enable instr. + STORE_WORD_IN_CS PROG,next1,AX ; Protected Mode Macro + mov s_break,0 ; reset shift-break flag + mov AX,2 ; set return value = 2 (begin debug) + jmp short exit_010 + +exit_op: dec SI ; back up PC to won't fall past end + mov AX,1 ; set return value = 1 (halt) + jmp short exit_010 + +exit: xor AX,AX ; set return value = 0 (suspend) +exit_010: mov SP,BP + mov BX,[BP].cod_ent + mov [BX],SI + add SP,offset sint_BP + pop BP + mov DX,DGROUP + mov ES,DX + ret +run endp + +prog ends + end + \ No newline at end of file diff --git a/sinterp.mac b/sinterp.mac new file mode 100644 index 0000000..9e0e6cd --- /dev/null +++ b/sinterp.mac @@ -0,0 +1,20 @@ +;*************************************** +;* TIPC Scheme '84 Runtime Support * +;* Interpreter Macros * +;* * +;* (C) Copyright 1984 by Texas * +;* Instruments Incorporated. * +;* All rights reserved. * +;* * +;* Date Written: 2 May 1984 * +;* Last Modification: 14 Sept. 1984 * +;*************************************** +; Call "printf" to produce error message +error macro args + irp txt, + lea BX,txt + push BX + endm + jmp printf_c + endm + \ No newline at end of file diff --git a/sio.asm b/sio.asm new file mode 100644 index 0000000..73a5edb --- /dev/null +++ b/sio.asm @@ -0,0 +1,292 @@ +; =====> SIO.ASM +;*************************************** +;* TIPC Scheme '84 Runtime Support * +;* I/O Utilities * +;* * +;* (C) Copyright 1984,1985 by Texas * +;* Instruments Incorporated. * +;* All rights reserved. * +;* * +;* Date Written: June 1984 * +;* Last Modification: 09 July 1985 * +;*************************************** + 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 + +;For space and performance reasons, some procedures have been written in the +; following style: the arguments are popped off the stack, and the +; procedure ends in an indirect JMP instead of a RET. In this source file, +; the following are such procedures: +; isspace, copybig + +; Find approximate space left on stack +; Caling sequence: stkspc() + extrn _base:word + public stkspc +stkspc proc near + mov AX,SP + sub AX,DGROUP:_base + ret +stkspc endp + +; Parse input integer +; Calling sequence: buildint(work,buf,base) +; Where ---- work: pointer to some workspace +; buf: pointer to integer characters +; base: numeric base +int_args struc + dw ? ;Caller's BP + dw ? ;Return address +bigptr dw ? ;Pointer to workspace +atptr dw ? ;Pointer to integer characters +bas dw ? ;Numeric base +int_args ends + public buildint +buildint proc near + push BP + mov BP,SP + cld ;Direction forward + mov SI,[BP].atptr ;Point DS:SI to characters + lodsb ;Fetch first character + cmp AL,'-' ;Negative? + pushf ;Save ZF + je negint ;Jump if negative + cmp AL,'+' ; or if signed positive + je negint + dec SI ;Point SI back to first char +negint: mov CX,1 ;At first, bignum is one word + add word ptr[BP].bigptr,3 ;Point BIGPTR to bignum proper +skiplp: lodsb ;Get first number char + cmp AL,'#' ;We know the base - skip all #x's + jne skipped ;All #x's skipped - parse number + inc SI ;Otherwise check again + jmp skiplp +biglp: lodsb ;Get next int character +skipped: mov DI,[BP].bigptr ;Point ES:DI to workspace + sub AL,'0' ;Character -> number + js bigend ;Jump if number ended + cmp AL,9 ;Jump if ordinary digit + jbe orddig + and AL,7 ;Otherwise, parse extra hex digit + add AL,9 +orddig: xor AH,AH ;Clear AH + call bigx10 ;Multiply bignum by 10, adding digit + jmp biglp +bigend: sub DI,3 ;Point DI back to start of buffer + mov AX,CX ;Save integer size + stosw + xor AL,AL ;Clear AX + popf ;Get number's sign + jne stosgn ;Store it + inc AL +stosgn: mov [DI],AL + pop BP ;Restore BP + ret +;BIGX10: Multiply bignum at ES:[DI], size=CX words, by BASE and add AX +bigx10: push CX + mov DX,AX ;Transfer digit to add + cld +x10lp: mov AX,[DI] ;Get word to multiply + call wordx10 ;Multiply word by 10 + stosw ;Replace result + loop x10lp ;Loop 'til done + pop CX ;Restore CX + or DX,DX ;Does a carry remain? + jz samlen ;Jump if not + mov ES:[DI],DX ;Otherwise, enlarge bignum + inc CX +samlen: ret +;WORDX10: Multiply AX by BASE and add DX; product in AX, carry in DX +wordx10: push CX ;Save value of CX + push DX ;Save carry in + mul word ptr[BP].bas ;Multiply by BASE + pop CX ;Restore carry to CX + add AX,CX ;Add carry + adc DX,0 + pop CX ;Restore CX + ret +buildint endp + +; Copy bignum data to a math buffer +; Calling sequence: copybig(pg,ds,buf) +; Where: pg,ds ---- page & displacement of bignum +; buf ------ pointer to math buffer +cb_args struc + dw ? ;Caller's BP + dw ? ;Return address +cbpg dw ? ;Page +cbds dw ? ;Displacement +cbbuf dw ? ;Buffer pointer +cb_args ends + public copybig +copybig proc near + pop BX ;Pop return address to BX + mov DX,DS ;Save DS in DX + pop SI ;Fetch logical page number + sal SI,1 ;Convert + LoadPage DS,SI ;Get page segment +;;; mov DS,DGROUP:pagetabl+[SI] ;Get page segment + pop SI ;Get displacement + mov AX,[SI]+1 ;Get size of bignum proper (words) + sub AX,4 + shr AX,1 + add SI,3 ;Point DS:SI to sign byte + pop DI ;Point ES:DI to math buffer + cld ;Direction forward + stosw ;Store bignum size in math buffer + movsb ;Copy sign byte + mov CX,AX ;Copy bignum proper + rep movsw + mov DS,DX ;Restore DS + jmp BX ;Return +copybig endp + +; Convert buffered bignum to ASCII +; Calling sequence: big2asc(mathbuf,charbuf) +; Where: mathbuf --- pointer to buffered bignum +; charbuf --- pointer to ASCII charcater array +b2a struc + dw ? ;Caller's BP + dw ? ;Return address +mbuf dw ? ;Math buffer +cbuf dw ? ;Character buffer +b2a ends + public big2asc +big2asc proc near + push BP + mov BP,SP + mov SI,[BP].mbuf ;Fetch math buffer pointer + mov DI,[BP].cbuf ;Fetch character buffer pointer + cld ;Direction forward + lodsw ;Fetch bignum size + mov CX,AX + lodsb ;Fetch sign + test AL,1 ;Skip on positive bignum + jz posbig + mov AL,'-' ;First character: minus + stosb +posbig: mov BX,10 ;Set divisor to 10 + and AX,1 ;Push 0 or 1 (1 if start with -) +prtbglp: push AX + call divbig ;Divide bignum by 10 + mov AL,DL ;Store digit + add AL,'0' + stosb + pop AX ;Increment character counter + inc AX + or CX,CX ;Loop until bignum is zeroed + jnz prtbglp + mov CX,AX ;Transfer & save character count + push AX + sub DI,CX ;Point DI to beginning of string + call reverse ;Reverse digits in ASCII bignum + pop AX ;Restore character count + pop BP + ret +;Divide bignum at DS:SI, length CX words, by BX (ES=DS) +divbig: push CX ;Save count + push DI ;Save DI + add SI,CX ;Point SI to last word (most signif.) + add SI,CX + sub SI,2 + cmp [SI],BX ;Will working length be reduced? + pushf + mov DI,SI ;ES:DI = DS:SI + std ;Direction backward + xor DX,DX ;Clear carry in +divlp: lodsw ;Fetch piece of dividend + div BX + stosw ;Store quotient (retain remainder) + loop divlp + add SI,2 ;Point SI again to first word + popf + pop DI + pop CX + jae divdone ;Jump if bignum length not reduced + dec CX +divdone: ret ;Remainder left in DX +;Reverse the string containing CX characters at ES:DI (ES=DS) +reverse: cmp byte ptr[DI],'-' ;Start with minus? + jne revpos ;No, reverse whole string + inc DI ;Otherwise, don't include minus in reverse + dec CX +revpos: mov SI,DI ;Point SI to last string char + add SI,CX + dec SI + shr CX,1 ;Number of switches + or CX,CX ;Jump if no switches to make + jz revend +revlp: mov AL,[DI] ;Exchange outside bytes + xchg AL,[SI] + stosb + dec SI ;Move pointers inward + loop revlp +revend: ret +big2asc endp + +; Is character a whitespace? +; Calling sequence: isspace(ch) +; Where ch = character to check +; Returns zero iff not a whitespace +; NOTE: Before use, the C macro ISSPACE must not be defined +isspargs struc + dw ? ;Return address +issparg dw ? ;Argument +isspargs ends + public isspace +isspace proc near + pop DI ;Get return address + pop AX ;Get argument + cmp AL,' ' + je issp + cmp AL,9 + jb isntsp + cmp AL,13 + jbe issp +isntsp: xor AX,AX ;Set to zero +issp: jmp DI ;Return +isspace endp + +; Save stack pointer in case of abort +; Calling sequence: setabort() +; NOTE: Due to the program-sensitive nature of this routine, a call to +; SETABORT MUST be the very first in a C routine, and there must be +; NO preassigned local variables. + public setabort +setabort proc near + mov BX,SP ;Fetch stack pointer + mov SI,SS:[BX] ;Fetch return address + mov CL,CS:[SI-6] ;Fetch byte just before MOV BP,SP + cmp CL,55h ;Compare with PUSH BP opcode + je nolocal ;Jump if no extra stack space allocated + xor CH,CH ;Clear CH + add BX,CX ;Discount extra stack space +nolocal: add BX,2 ;Discount SETABORT's return address + mov DGROUP:abadr,BX ;Save pointer + ret +setabort endp + +; Abort & set stack to saved pointer +; Calling sequence: abort(code) +; where: code ---- type of error message to print + public abort +abort proc + pop AX ;Discard return address (leaving CODE) + C_call errmsg ;Print error message + pop AX ;Get "value" + mov SP,DGROUP:abadr ;Restore stack for abort + pop BP ;Restore BP + ret ;Return (from aborted operation) +abort endp +prog ends + end + + \ No newline at end of file diff --git a/slink.h b/slink.h new file mode 100644 index 0000000..738e30e --- /dev/null +++ b/slink.h @@ -0,0 +1,35 @@ +/* =====> SLINK.H */ +/* PC Scheme Lattice C Macros to Support Scheme to C Interface + Copyright 1985 by Texas Instruments Incorporated. + All Rights Reserved. + + Author: John C. Jensen + Installation: Texas Instruments Incorporated, Dallas, Texas + Division: Central Research Laboratories + Cost Center: Computer Science Laboratory + Project: Computer Architecture Branch + Date Written: 22 June 1985 + Last Modification: 23 June 1985 + + Purpose: The macros within this module provide the capability to + fetch values passed from the Scheme Runtime and return + values to the Scheme Runtime. + + Description: For a description of parameter passing conventions, see the + module header in the file SLINK.C. +*/ + +#define INTEGER(x) *((int *)x) +#define LONG_INTEGER(x) *x +#define FLOAT(x) *((float *)x) +#define DOUBLE(x) *((double *)x) +#define CHARACTER(x) *((char *)x) +#define STRING(x) ((char*)x) + +#define RETURN_NOVALUE() return(0) +#define RETURN_T_OR_NIL(x) **result = (x); return(1) +#define RETURN_INTEGER(x) **result = (x); return(2) +#define RETURN_FLONUM(x) *((double *) *result) = (x); return(3) +#define RETURN_CHARACTER(x) *((char *) *result) = (x); return(4) +#define RETURN_STRING(x) t_=(x);if(t_){*result=(long *)t_;return(5);}else{**result=0;return(1);} + \ No newline at end of file diff --git a/slist.h b/slist.h new file mode 100644 index 0000000..0a95927 --- /dev/null +++ b/slist.h @@ -0,0 +1,25 @@ +/************************************************************************/ +/* C Equivalents for Scheme List Operations */ +/* */ +/* Copyright 1985 by Texas Instruments Incorporated. */ +/* All Rights Reserved. */ +/* */ +/* Date Written: 29 March 1985 */ +/* Last Modification: 1 April 1985 */ +/************************************************************************/ + +/* copy contents of one "register" to another */ +#define mov_reg(dest,src) dest[C_PAGE]=src[C_PAGE]; dest[C_DISP]=src[C_DISP] + +/* test equality (eq? -ness) of two registers */ +#define eq(r1,r2) (r1[C_DISP] == r2[C_DISP] && r1[C_PAGE] == r2[C_PAGE]) + +/* take caar of a "register" */ +#define take_caar(reg) take_car(reg); take_car(reg) + +/* take cadr of a "register" */ +#define take_cadr(reg) take_cdr(reg); take_car(reg) + +/* take cddr of a "register" */ +#define take_cddr(reg) take_cdr(reg); take_cdr(reg) + \ No newline at end of file diff --git a/smmu.asm b/smmu.asm new file mode 100644 index 0000000..7a2d8de --- /dev/null +++ b/smmu.asm @@ -0,0 +1,173 @@ + name SMMU + title Scheme Memory Management Utilities + page 62,132 +; =====> SMMU.ASM +;**************************************************************** +;* TIPC Scheme '84 Memory Management Utilities * +;* * +;* (C) Copyright 1985, 1987 by Texas Instruments Incorporated. * +;* All rights reserved. * +;* * +;* Author: Terry Caudill * +;* Date written: 18 March 1986 * +;* History: * +;* rb 4/ 5/87 "getbase" returns a page's swap state in carry * +;* (for compatibility with PCSEXT and PCSEXP) * +;**************************************************************** + include schemed.equ + include schemed.ref + +DOS equ 021h + +DGROUP group data +PGROUP group prog + +data segment word public 'DATA' + assume ds:DGROUP + extrn page0:byte, page4:byte, page5:byte, page6:byte + extrn page7:byte, page8:byte + + extrn _top:word, _paras:word,first_pa:word,first_dos:word + + public GC_ING +GC_ING dw 0 + +data ends + + +prog segment byte public 'PROG' + assume cs:PGROUP + +;;====================================================================== +;; +;; Get page base address of page +;; +;; On exit, carry is clear to indicate page is always in memory +;; (for compatibility with extended and expanded versions of this routine) +;; +;;====================================================================== + + public getbase +getbase proc near + push BP + mov BP,SP + mov BX,word ptr [BP+4] + mov AX,word ptr [BX+pagetabl] ;; Get table indicator + clc ;; page always avail in conv. memory + pop BP + ret + +getbase endp + +;;====================================================================== +;; +;; InitMem() +;; Compute the best page size, but not smaller than MIN_PAGESIZE +;; +;;====================================================================== + + + + + public InitMem +InitMem proc near + push BP + sub SP,2 ;; Local storage + mov BP,SP + + mov BX,DS + mov ES,BX ;; Ensure ES = DS + +;; Convert offset within pagetabl[0] into paragraph address + + mov DI,offset pagetabl + mov AX,word ptr [DI] + mov CX,4 + shr AX,CL + add AX,BX + mov word ptr [DI],AX + +;; Same for pagetabl[4] through pagetabl[8] + + mov DX,5 + mov DI,offset pagetabl[8] +EmmP$0: + mov AX,word ptr [DI] + shr AX,CL + add AX,BX + mov word ptr [DI],AX + add DI,2 + dec DX + jnz EmmP$0 + +;; Allocate all the memory that DOS will give us. + + mov BX,0FFFFh ;; first ask for too much + mov AH,048h + int DOS ;; DOS gets an error, but tells us + ;; in BX how much we CAN get + mov AH,048h + int DOS ;; reissue allocation request + mov first_dos,AX ;; save address for returning it to DOS + mov first_pa,AX ;; save address for Scheme heap + +;; Compute the best page size, but not smaller than MIN_PAGESIZE + + mov AX,_paras ;; max number of paragraphs + sub AX,first_pa ;; subtract first paragragh + xor DX,DX ;; get ready for divide + mov CX,NUMPAGES-PreAlloc ;; CX <= number heap allocated pages + idiv CX ;; AX <= paras-per-page + + mov DX,(MIN_PAGESIZE shr 4) + cmp AX,DX ;; If paras-per-page < MIN_PAGESIZE/16 + jge EmmP$05 ;; then + mov AX,DX ;; paras-per-page = MIN_PAGESIZE/16 +EmmP$05: + mov [BP],AX ;; Save paras-per-page + +;; Pagesize = (paras-per-page * 16) + + mov CX,4 + shl AX,CL + mov pagesize,AX + mov SI,AX + +;; Initialize page management table + + xor CX,CX ;; Keep number of pages in CX + mov DX,nextpage + mov freepage,DX ;; freepage = nextpage + mov AX,first_pa ;; AX <= next paragraph + mov DI,_paras ;; DI <= (_paras - paras per page) + sub DI,[BP] +EmmP$1: + cmp DI,AX ;; Did we reach it + jb EmmP$2 ;; Yes...no more + cmp DX,NUMPAGES ;; See if we have filled the table + jae EmmP$2 + mov BX,DX + shl BX,1 + mov word ptr [BX+pagetabl],AX + mov word ptr [BX+psize],SI + and word ptr [BX+attrib],not NOMEMORY + inc DX + mov word ptr [BX+pagelink],DX + mov word ptr [BX+nextcell],0 + inc CX ;; page_count++ + add AX,[BP] ;; nextpara = nextpara + para per page + jmp EmmP$1 +EmmP$2: + mov nextpage,DX ;; nextpage = lastpage + mov lastpage,DX + mov AX,CX + pop BP + pop BP + ret + +InitMem endp + +prog ends + + end + \ No newline at end of file diff --git a/smmu.mac b/smmu.mac new file mode 100644 index 0000000..ab84806 --- /dev/null +++ b/smmu.mac @@ -0,0 +1,301 @@ +;******************************************************************************* +;* TIPC Scheme '84 Runtime Support - Assembler Macros * +;* * +;* (C) Copyright 1984,1985 by Texas Instruments Incorporated. * +;* All rights reserved. * +;* * +;* Memory and Machine specific macros to aid in the building specific * +;* of PC Scheme. There are four versions of the PC Scheme system: * +;* 1. Conventional Memory Scheme * +;* 2. Expanded Memory Scheme * +;* 3. Extended Memory Scheme * +;* 4. Protected Mode Scheme * +;* These macros create version specific code for each of the above schemes. * +;* The Macro assembler symbols REGMEM, EXPMEM, EXTMEM, and PROMEM are used * +;* to conditionally define the correct macros. It can be (and must be) * +;* specified on the MASM command line during the assembly phase as follows: * +;* MASM /DREGMEM srcfile,objfile,... * +;* * +;* Date Written: 29 July 1987 * +;* * +;* * +;******************************************************************************* + + +;;; +;;; Macros for conventional memory version - default +;;; + + ; The LoadPage macros should be used to obtain the address of a given page + ; from the pagetable. This must be done in order to access any given heap + ; allocated object. For conventional memory, this just means indexing into + ; the pagetable and accessing the paragraph address, however for extended + ; and expanded memories, it is quite different. See the macro definitions + ; for EXPMEM and EXTMEM for definitions for expanded and extended memorys. + + LoadPage MACRO dst,src ; Get Page address from page table + IFIDN , + mov dst,[SS:pagetabl+src] + ELSE + IFIDN , + mov dst,[SS:pagetabl+src] + ELSE + IFIDN , + mov dst,[SS:pagetabl+src] + ELSE + IFIDN , + mov dst,[SS:pagetabl+src] + ELSE + IFIDN , + mov dst,[SS:pagetabl+src] + ELSE + IFIDN , + mov dst,[SS:pagetabl+src] + ELSE + IFIDN , + mov dst,[SS:pagetabl+src] + ELSE + push BX + mov BX,src + mov dst,[SS:pagetabl+BX] + pop BX + ENDIF + ENDIF + ENDIF + ENDIF + ENDIF + ENDIF + ENDIF + ENDM + + %LoadPage MACRO dst,src + LoadPage dst,src + ENDM + + %LoadPage0 MACRO dst,src + LoadPage dst,src + ENDM + + %LoadPage1 MACRO dst,src + LoadPage dst,src + ENDM + + LoadCode MACRO dst,src + LoadPage dst,src + ENDM + + ; The following macros should be used whenever saving some value in a + ; location within the code segment. For real mode, you may store anything + ; within the code segment, however in protected mode, this causes a + ; protection violation. See the macro expansions for PROMEM to see how + ; this may be accomplished in protected mode. + + STORE_WORD_IN_CS MACRO SEG,OFFSET,VALUE + mov word ptr CS:OFFSET,VALUE + ENDM + + STORE_BYTE_IN_CS MACRO SEG,OFFSET,VALUE + mov byte ptr CS:OFFSET,VALUE + ENDM + + XCHG_WORD_IN_CS MACRO SEG,OFFSET,VALUE + xchg word ptr CS:OFFSET,VALUE + ENDM + + +IFDEF REGMEM + ; Access to pagetabl for LoadPage macros + extrn pagetabl:word +ENDIF + + +;;; +;;; Macros for expanded memory version +;;; + +IFDEF EXPMEM + ; get rid of default conventional memory definitions + purge LoadPage,%LoadPage,%LoadPage0,%LoadPage1,LoadCode + + ; Load page address + extrn _MMU:near + LoadPage MACRO dst,src + push src + call _MMU + pop dst + ENDM + + ; Load code block + extrn _MMUCB:near + LoadCode MACRO dst,src + push src + call _MMUCB + pop dst + ENDM + + ; SAME AS LoadPage EXCEPT CALLABLE FROM PROGX SEGMENT + extrn _%MMU:far + %LoadPage MACRO dst,src + IF1 + IFIDN , + %OUT *AX as destination of %LoadPage not recommended* + ELSE + IFIDN , + %OUT *AX as destination of %LoadPage not recommended* + ENDIF + ENDIF + ENDIF + push AX + mov AX,src + call _%MMU + mov dst,AX + pop AX + ENDM + + ; Loads only Emm page 0 + extrn _%MMU0:far + %LoadPage0 MACRO dst,src + IF1 + IFIDN , + %OUT *AX as destination of %LoadPage0 not recommended* + ELSE + IFIDN , + %OUT *AX as destination of %LoadPage0 not recommended* + ENDIF + ENDIF + ENDIF + push AX + mov AX,src + call _%MMU0 + mov dst,AX + pop AX + ENDM + + ; Loads only Emm page 1 + extrn _%MMU1:far + %LoadPage1 MACRO dst,src + IF1 + IFIDN , + %OUT *AX as destination of %LoadPage1 not recommended* + ELSE + IFIDN , + %OUT *AX as destination of %LoadPage1 not recommended* + ENDIF + ENDIF + ENDIF + push AX + mov AX,src + call _%MMU1 + mov dst,AX + pop AX + ENDM +ENDIF + + +;;; +;;; Macros for extended memory version +;;; + + +IFDEF EXTMEM + ; get rid of default conventional memory definitions + purge LoadPage,%LoadPage,%LoadPage0,%LoadPage1,LoadCode + + ; Load page address + extrn _MMU:near + LoadPage MACRO dst,src + push src + call _MMU + pop dst + ENDM + + ; SAME AS LoadPage EXCEPT CALLABLE FROM PROGX SEGMENT + extrn _%MMU:far + %LoadPage MACRO dst,src + IF1 + IFIDN , + %OUT *AX as destination of %LoadPage not recommended* + ELSE + IFIDN , + %OUT *AX as destination of %LoadPage not recommended* + ENDIF + ENDIF + ENDIF + push AX + mov AX,src + call _%MMU + mov dst,AX + pop AX + ENDM + + ; The following macros are provided for comatibility with the + ; Expanded memory version. They just perform a LoadPage. + + ; Load code block + LoadCode MACRO dst,src + LoadPage dst,src + ENDM + + %LoadPage0 MACRO dst,src + %LoadPage dst,src + ENDM + + %LoadPage1 MACRO dst,src + %LoadPage dst,src + ENDM + +ENDIF + + +;;; +;;; Macros for protected mode version +;;; + +IFDEF PROMEM + ; get rid of default real mode definitions + purge STORE_WORD_IN_CS,STORE_BYTE_IN_CS,XCHG_WORD_IN_CS + + ; Access to pagetabl for LoadPage macros + extrn pagetabl:word + + STORE_WORD_IN_CS MACRO SEG,OFFSET,VALUE + push DS + push AX + mov AX,CS + and AX,0FFF7H + mov DS,AX + pop AX + assume DS:SEG + mov word ptr DS:OFFSET,VALUE + assume DS:DGROUP + pop DS + ENDM + + STORE_BYTE_IN_CS MACRO SEG,OFFSET,VALUE + push DS + push AX + mov AX,CS + and AX,0FFF7H + mov DS,AX + pop AX + assume DS:SEG + mov byte ptr DS:OFFSET,VALUE + assume DS:DGROUP + pop DS + ENDM + + XCHG_WORD_IN_CS MACRO SEG,OFFSET,VALUE + push DS + push AX + mov AX,CS + and AX,0FFF7H + mov DS,AX + pop AX + assume DS:SEG + xchg word ptr DS:OFFSET,VALUE + assume DS:DGROUP + pop DS + ENDM + + +ENDIF \ No newline at end of file diff --git a/sobjhash.asm b/sobjhash.asm new file mode 100644 index 0000000..0fc45d0 --- /dev/null +++ b/sobjhash.asm @@ -0,0 +1,458 @@ +; =====> SOBJHASH.ASM +;*************************************** +;* TIPC Scheme Runtime Support * +;* Object Hashing Routines * +;* * +;* (C) Copyright 1985 by Texas * +;* Instruments Incorporated. * +;* All rights reserved. * +;* * +;* Date Written: 25 June 1985 * +;* Last Modification: 3 November 1985 * +;*************************************** + include scheme.equ + +DGROUP group data +XGROUP group PROGX +PGROUP group prog + +data segment word public 'DATA' + assume DS:DGROUP +obj_cntr dw OHT_SIZE dup (1) +branchtab dw ogc_list ; [0] List cells + dw ogc_mark ; [1] Fixnums + dw ogc_var ; [2] Flonums + dw ogc_var ; [3] Bignums + dw ogc_var ; [4] Symbols + dw ogc_var ; [5] Strings + dw ogc_var ; [6] Arrays + dw ogc_var ; [7] Continuations + dw ogc_var ; [8] Closures + dw ogc_mark ; [9] Free page + dw ogc_var ; [10] Code page + dw ogc_mark ; [11] Reference cells + dw ogc_var ; [12] Port data objects + dw ogc_mark ; [13] Characters + dw ogc_var ; [14] Environments +ret_sav1 dw 0 ; return address save area +ret_sav2 dw 0 ; return address save area +data ends + +prog segment byte public 'PROG' + assume CS:PGROUP + +;************************************************************************ +;* Far Linkage to "lookup" Routine * +;************************************************************************ +%lookup proc far + extrn lookup:near + call lookup + ret +%lookup endp + +;************************************************************************ +;* Far Linkage to "cons" Routine * +;************************************************************************ + public %cons +%cons proc far + pop ret_sav1 + pop ret_sav2 + mov AX,DS ; make ES point to the data segment + mov ES,AX + extrn cons:near + call cons + push ret_sav2 + push ret_sav1 + ret +%cons endp + +;************************************************************************ +;* Far Linkage to "alloc_block" Routine * +;************************************************************************ + public %allocbl +%allocbl proc far + pop ret_sav1 + pop ret_sav2 + mov AX,DS ; make ES point to the data segment + mov ES,AX + extrn alloc_bl:near + call alloc_bl + push ret_sav2 + push ret_sav1 + ret +%allocbl endp +prog ends + +PROGX segment byte public 'PROGX' + assume CS:XGROUP +;************************************************************************ +;* Object Hash * +;************************************************************************ +oh_args struc +oh_key dw ? ; computed hash key +oh_key3 dw ? ; computed hash key * 3 +oh_disp dw ? ; page number component of a pointer +oh_page dw ? ; displacement component of a pointer +oh_reg dw ? ; pointer to argument register (s=d) +oh_ctr dw ? ; bucket's current counter value +oh_ctag db SPECFIX*2,? ; tag for counter +oh_BP dw ? ; caller's BP + dw ? ; caller's SI + dw ? ; caller's ES + dd ? ; return address (far call) + dw ? ; return address (near call) +oh_args ends + +%objhash proc far + lods byte ptr ES:[SI] ; fetch operand of object-hash + push ES ; save the caller's ES register + push SI ; save the location counter + push BP ; save the caller's BP register + sub SP,offset oh_BP ; allocate local storage + mov BP,SP ; establish local addressability +; load argument and compute hash index + mov BX,AX ; copy dest=src register number to BX + add BX,offset reg0 ; and compute the register's address + mov [BP].oh_reg,BX ; save the register address +;;; +;;; Note: computing of hash value turned off 'cause relocation of +;;; pointers screws things up. For now, all objects will +;;; hash to a key of zero. (JCJ 2 OCT 85) +;;; mov DX,[BX].C_page ; load the argument's page number +;;; mov AX,[BX].C_disp ; load the argument's displacement +;;; mov CL,AH ; copy high byte of displacement +;;; xor AH,AH +;;; xor CH,CH +;;; add AX,CX +;;; add AX,DX +;;; mov CX,OHT_SIZE ; load the hash table size for divisor +;;; cwd ; convert dividend to double word +;;; div CX ; divide hash value by table size + xor DX,DX ; ***TEMPORARY*** Load a hash key of zero +;;; + mov [BP].oh_key,DX ; save computed hash key + mov SI,DX + shl DX,1 + add SI,DX ; SI <- hash_key * 3 + mov [BP].oh_key3,SI + +; if entries exist at this hash level, search bucket for object + cmp obj_ht+[SI],0 ; anyone home in this bucket? + je oh_nf ; if no entries exist, jump + +; call "lookup" to search a-list + mov AX,[BX].C_disp ; reload object's displacement + mov DX,[BX].C_page ; and page for a-list search + xor BX,BX + mov BL,obj_ht+[SI] + %LoadPage ES,BX +;;; mov ES,pagetabl+[BX] + mov SI,word ptr obj_ht+[SI]+1 + call %lookup ; search the a-list + cmp BL,0 + je oh_nf + +; object found in hash bucket's chain-- return it + mov AX,ES:[DI].cdr ; load the hash counter + mov [BP].oh_ctr,AX ; and save it in 'oh_ctr' + jmp short oh_ret ; return hash value + +; make a new entry in the current hash bucket +oh_nf: mov DI,[BP].oh_key + shl DI,1 ; multiply hash value by 2 for index + mov AX,obj_cntr+[DI] ; load obj hash counter for this bucket + inc obj_cntr+[DI] ; increment the obj hash counter + mov [BP].oh_ctag,SPECFIX*2 ; convert hash counter to a fixnum + mov [BP].oh_ctr,AX ; pointer + lea BX,[BP].oh_ctr ; load hash counter's "reg" address + mov AX,[BP].oh_reg ; load object's register address + mov CX,offset tmp_reg ; load offset of temporary register + pushm ; push arguments to call + call %cons ; cons(tmp_reg, object, hash-counter) + mov BX,offset nil_reg ; load address of "nil register" + mov CX,offset tmp_reg ; load address of temporary register + pushm ; push arguments to cons + call %cons ; cons(tmp_reg, (cons obj hash), nil) + mov SP,BP ; drop arguments from stack + mov DI,[BP].oh_key3 ; load hash bucket number * 3 + mov BX,tmp_page ; load pointer to newest list cell + mov AX,tmp_disp + %LoadPage ES,BX +;;; mov ES,pagetabl+[BX] + mov SI,AX ; pointer is in ES:[SI] + xchg obj_ht+[DI],BL ; header <- pointer to list cell + xchg word ptr obj_ht+[DI]+1,AX + mov ES:[SI].cdr_page,BL ; (set-cdr! list-cell chain-header) + mov ES:[SI].cdr,AX + +; create a bignum to hold the hash value +oh_ret: mov AX,WORDINCR*2+1 ; load the size of bignum result + push AX ; and push it for use as argument + mov AX,BIGTYPE ; load type=bignum + push AX ; and push it for use as argument + push [BP].oh_reg ; push address of destination register + mov AX,DS ; ES <- DS + mov ES,AX + call %allocbl ; allocate the bignum + mov SP,BP ; drop arguments off the TIPC's stack + mov BX,[BP].oh_reg ; load destination register's address + mov SI,[BX].C_page ; load bignum's page number + %LoadPage ES,SI ; load bignum page's paragraph address +;;; mov ES,pagetabl+[SI] ; load bignum page's paragraph address + mov SI,[BX].C_disp ; load bignum's displacement + mov AX,[BP].oh_key ; load hash bucket number + mov ES:[SI].big_data,AX ; and store it into LSW of bignum + mov AX,[BP].oh_ctr ; load counter for this object + mov ES:[SI].big_2nd,AX ; and store it into MSW of bignum + mov ES:[SI].big_sign,0 ; sign <- 0 (positive number) + +; return to caller + add SP,offset oh_BP ; deallocate local storage + pop BP ; restore caller's BP register + pop SI ; restore the location pointer + pop ES ; restore caller's ES register + ret ; return to calling procedure +%objhash endp + +;************************************************************************ +;* Object Unhash * +;************************************************************************ +unhs_arg struc +un_reg dw ? ; argument register address +un_BP dw ? ; caller's BP + dw ? ; caller's SI + dw ? ; caller's ES + dd ? ; return address (far call) + dw ? ; return address (near call) +unhs_arg ends + +%objunhs proc far + lods byte ptr ES:[SI] ; load the operand for object-unhash + push ES ; save the caller's ES register + push SI ; save the location pointer + push BP ; save the caller's BP register + sub SP,offset un_BP ; allocate local storage + mov BP,SP ; establish local addressability + +; Begin the long process of validating the input + mov SI,AX + add SI,offset reg0 + mov [BP].un_reg,SI + mov BX,[SI].C_page + cmp byte ptr ptype+[BX],BIGTYPE*2 + je un_maybe + +; This hash-key is invalid, or object not found-- return #!false +un_false: xor AX,AX ; create a nil pointer + mov SI,[BP].un_reg ; load destination register address + mov byte ptr [SI].C_page,AL ; store nil pointer into + mov [SI].C_disp,AX ; destination register + +; Return to Scheme Interpreter +un_ret: add SP,offset un_BP ; deallocate local storage + pop BP ; restore caller's BP register + pop SI ; restore the location pointer + pop ES ; restore caller's ES register + ret + +; Continue checking bignum value +un_maybe: mov SI,[SI].C_disp ; load bignum's offet + %LoadPage ES,BX ; and paragraph address +;;; mov ES,pagetabl+[BX] ; and paragraph address + cmp ES:[SI].big_sign,0 + jne un_false ; if negative, not one of ours + cmp ES:[SI].big_len,8 + jne un_false ; if more than four bytes of data, not ours + mov DI,ES:[SI].big_data ; load least significant word (bucket no.) + cmp DI,OHT_SIZE + jae un_false ; hash bucket index too large? if so, jump + mov DX,DI ; DX <- bucket number + mov AX,ES:[SI].big_2nd + shl DI,1 ; DI <- bucket number * 2 + cmp AX,obj_cntr+[DI] ; test against next available counter value + jae un_false ; hash index too large? if so, jump +; Note: Search index (key) is in AX + add DI,DX ; DI <- bucket number * 3 + add DI,offset obj_ht + mov DX,DS ; ES <- DS + mov ES,DX +; Note: Search list whose header is in ES:[DI] + call oh_search ; search "ES:[DI]" for "AX" + cmp BL,0 ; was index found? + je un_false ; if not found, return #!false (jump) +; Search successful-- object/hash-value pair pointed to by ES:[SI] + mov DI,[BP].un_reg ; load destination register's address + mov AX,ES:[SI].car ; copy car field of found pair into + mov [DI].C_disp,AX ; the destination register + mov AL,ES:[SI].car_page + mov byte ptr [DI].C_page,AL + jmp un_ret ; return to caller w/ object in dest reg +%objunhs endp + +;************************************************************************ +;* Local Support for Object Unhash * +;************************************************************************ +oh_search proc near +; Compute pointer to current entry and save it + mov BL,ES:[DI].car_page + cmp BL,0 + je oh_sret + mov DI,ES:[DI].car + %LoadPage ES,BX +;;; mov ES,pagetabl+[BX] + mov DX,ES ; save ES in DX +; Compute pointer to object/hash-key pair + mov BL,ES:[DI].car_page + mov SI,ES:[DI].car + %LoadPage ES,BX +;;; mov ES,pagetabl+[BX] +; Test cdr field (hash key) of pair for match + cmp ES:[SI].cdr,AX + jne oh_smore +; A match!-- Return pair address in ES:[SI] +oh_sret: ret + +oh_smore: mov ES,DX ; restore ES + add DI,PTRSIZE ; adjust pointer to cdr field of curr entry + jmp oh_search ; iterate +oh_search endp + +;************************************************************************ +;* Object Hash Table Garbage Collection * +;************************************************************************ +gc_args struc +prev_ES dw ? ; ES for previous entry +prev_off dw ? ; offset for previous entry +curr_PG dw ? ; ES for current entry +curr_off dw ? ; offset for current entry +pair_PG dw ? ; ES for object/hash-key pair +pair_off dw ? ; offset for object/hash-key pair +gc_BP dw ? ; caller's BP + dw ? ; caller's ES + dd ? ; return address (far call) + dw ? ; return address (near call) +gc_args ends + +%gc_oht proc far + push ES ; save caller's ES register + push BP ; save caller's BP register + sub SP,offset gc_BP ; allocate local storage + mov BP,SP ; establish addressibility for local storage + +; Initialize parameters + mov SI,offset obj_ht ; load address of object hash table + mov CX,OHT_SIZE ; load number of entries in obj hash table +gc_loop: mov AX,DS ; ES <- DS + mov ES,AX + push SI ; load current object hash table offset + push CX ; save iteration counter + call gc_nxt ; follow this entries chain + pop CX ; restore iteration counter + pop SI ; restore obj hash table offset + add SI,PTRSIZE ; advance offset pointer + loop gc_loop ; continue 'til all buckets processed + +; Return to caller +gc_xit: add SP,offset gc_BP ; release local storage + pop BP ; restore the caller's BP register + pop ES ; restore the caller's ES register + ret ; return +%gc_oht endp + +;************************************************************************ +;* Local Support for Object Hash Table Garbage Collection * +;************************************************************************ +gc_nxt proc near + xor BX,BX ; clear register BX + mov BL,ES:[SI].car_page ; load page number for next entry + cmp BL,0 ; does entry exist? + jne ogc_010 ; if null pointer, jump to exit + ret ; return to gc_oht +; save pointer to previous cell +ogc_010: mov [BP].prev_ES,ES + mov [BP].prev_off,SI +; compute and save pointer to current cell + mov DI,ES:[SI].car + %LoadPage ES,BX +;;; mov ES,pagetabl+[BX] + mov [BP].curr_PG,BX + mov [BP].curr_off,DI +; compute and save pointer to object/hash-key pair + mov BL,ES:[DI].car_page + mov SI,ES:[DI].car + test SI,08000h ; is current cell marked as referenced? + jnz ogc_skip ; if marked, GC during OBJECT-HASH (jump) + %LoadPage ES,BX +;;; mov ES,pagetabl+[BX] + mov [BP].pair_PG,BX + mov [BP].pair_off,SI +; see what object pointer points to + mov BL,ES:[SI].car_page + cmp BL,DEDPAGES*PAGEINCR ; is object a "special" one? + jb ogc_mark ; if a non-gc'ed page, must keep entry + mov SI,ES:[SI].car ; load object offset + %LoadPage ES,BX +;;; mov ES,pagetabl+[BX] ; load object's paragraph address + mov DI,ptype+[BX] ; load type code for object + jmp branchtab+[DI] ; jump to appropriate routine + +; object is a list cell-- test to see if it's marked +ogc_list: test byte ptr ES:[SI].list_gc,GC_BIT + jnz ogc_mark + jmp short ogc_del + +; Variable length object +ogc_var: test byte ptr ES:[SI].vec_gc,GC_BIT + jnz ogc_mark + +; Object not referenced-- delete object hash table entry for it +ogc_del: %LoadPage ES,[BP].curr_PG ; reload pointer to current entry + mov SI,[BP].curr_off + mov AX,ES:[SI].cdr ; load cdr field of current entry + mov BL,ES:[SI].cdr_page + mov ES,[BP].prev_ES ; reload pointer to previous entry + mov SI,[BP].prev_off + mov ES:[SI].car,AX ; store cdr field of current entry into + mov ES:[SI].car_page,BL ; previous entry + jmp gc_nxt ; process next entry + +; Object is marked as referenced-- mark obj hash table cells as referenced +ogc_mark: %LoadPage ES,[BP].pair_PG ; load pointer to object/hash-key pair + mov SI,[BP].pair_off + or byte ptr ES:[SI].list_gc,GC_BIT ; mark pair entry referenced +ogc_skip: %LoadPage ES,[BP].curr_PG ; load pointer to current entry + mov SI,[BP].curr_off + or byte ptr ES:[SI].list_gc,GC_BIT ; mark curr entry referenced + add SI,PTRSIZE ; advance pointer to cdr field of curr entry + jmp gc_nxt ; process next entry +gc_nxt endp + +PROGX ends + +prog segment byte public 'PROG' + assume CS:PGROUP +;************************************************************************ +;* Linkage to Object Hash Routine * +;************************************************************************ + public obj_hash +obj_hash proc near + call %objhash + extrn next:near + jmp next ; return to the Scheme interpreter +obj_hash endp + + public obj_unhs +obj_unhs proc near + call %objunhs + jmp next ; return to the Scheme interpreter +obj_unhs endp + + public gc_oht +gc_oht proc near + call %gc_oht + ret +gc_oht endp + +prog ends + end + \ No newline at end of file diff --git a/sport.h b/sport.h new file mode 100644 index 0000000..6343536 --- /dev/null +++ b/sport.h @@ -0,0 +1,136 @@ +/* -----> SPORT.H */ +/* TIPC Scheme Runtime Support - I/O Control Structure Definition + Copyright 1985 by Texas Instruments Incorporated. + All Rights Reserved. + + Author: John C. Jensen + Installation: Texas Instruments Incorporated, Dallas, Texas + Division: Corporate Research Laboratories + Cost Center: Computer Science Laboratory + Project: Computer Architecture Branch + Date Written: 1 February 1985 + Last Modification: 18 July 1985 by Mark Meyer + 22 Jan 1987 by dbs - added random i/o +*/ + +/* The format of a window data object is: + + +--------+--------+--------+ + 0 |tag=port| length in bytes | + +--------+-----------------+ + 3 | 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 buffer | + +--------+--------+-----------------+-------...---+ + | window label | + +--------+--------+-----------------+---------...-+ + + 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 flag: 0=text file/window + 1=binary file/window + s - string I/O: 0=file or window + 1=I/O from/to string + + 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 + + The format of a file data object is: + + +--------+--------+--------+ + 0 |tag=port| length in bytes | + +--------+-----------------+ + 3 | null | + +--------+--------+--------+--------+ + 6 | port flags | handle | + +-----------------+-----------------+ + 10 | pathname offset | current column | + +-----------------+-----------------+ + 14 | chunk # | (reserved) | + +-----------------+-----------------+ + 18 |file size (high) |number of columns| + +-----------------+-----------------+ + 22 | file size (low) | (reserved) | + +-----------------+-----------------+ + 26 | (reserved) | buffer position | + +-----------------+-----------------+ + 30 | buffer end | + +--------+--------+--------+--------+----... -----+ + 32 | input/output buffer ... | + +--------+--------+-----------------+-------... --+ + | file pathname ... | + +--------+--------+-----------------+---------... + + +*/ +#define READ 0x00 +#define WRITE 0x01 +#define APPEND 0x02 +#define READ_WRITE 0x02 +#define WINDOW 0x04 +#define OPEN 0x08 +#define TRANSCRIPT 0x10 +#define BINARY 0x20 +#define STRSRC 0x40 + +#define WRAP 0x01 + +#define MAX_LINES 25 /* number of lines on the VDT */ +#define MAX_COLUMNS 80 /* number of columns on the VDT */ +#define WINDSIZE 32-BLK_OVHD +#define BUFFSIZE 256 /* input/output buffer size (bytes) */ + +#define STR_PTR 3 /* pointer to source string, if any */ +#define P_FLAGS 6 /* port flags */ +#define HANDLE 8 /* file/device handle */ +#define CUR_LINE 10 /* current line/record number */ +#define CUR_COL 12 /* current column/record number */ +#define UL_LINE 14 /* window: upper left corner's line number */ + /* file: chunk # */ +#define UL_COL 16 /* window: upper left corner's column number */ +#define N_LINES 18 /* window: number of lines */ + /* file: high word of file size */ +#define N_COLS 20 /* line length */ +#define B_ATTRIB 22 /* window: border attributes */ + /* file: low word of file size */ +#define T_ATTRIB 24 /* window: text attributes */ +#define W_FLAGS 26 /* window: flags */ +#define BUF_POS 28 /* current buffer position */ +#define BUF_END 30 /* current end of buffer offset */ + +#define BUFR 32 /* input/output buffer */ +#define LABEL 32+BUFFSIZE /* window label field */ +#define PATHNAME 32+BUFFSIZE /* file pathname field */ + \ No newline at end of file diff --git a/squish.asm b/squish.asm new file mode 100644 index 0000000..0a8dc51 --- /dev/null +++ b/squish.asm @@ -0,0 +1,753 @@ +; =====> SQUISH.ASM +;*************************************** +;* TIPC Scheme Runtime Support * +;* Memory Compaction Routines * +;* * +;* (C) Copyright 1985 by Texas * +;* Instruments Incorporated. * +;* All rights reserved. * +;* * +;* Date Written: 23 September 1985 * +;* Last Modification: 22 October 1985 * +;* * +;* rb 2/ 2/88 - put in TC's GC fix * +;* * +;*************************************** + .286c ;; Utilize the expanded 80286 instruction set + include scheme.equ + +DGROUP group data +XGROUP group PROGX +PGROUP group prog + +MSDOS equ 021h + +data segment word public 'DATA' + assume DS:DGROUP +ret_sav1 dw 0 ; return address save area +ret_sav2 dw 0 ; return address save area +;;;msg db " Compacting Memory *",0 +;;;msg1a db "Moving List Cells",LF,0 +;;;msg1b db "Moving Flonums",LF,0 +;;;msg1c db "Moving Bignums",LF,0 +;;;msg1d db "Moving Closures",LF,0 +;;;msg1e db "Moving Code Blocks",LF,0 +;;;msg1f db "Moving Vectors",LF,0 +;;;msg1g db "Moving Continuations",LF,0 +;;;msg1h db "Moving Symbols",LF,0 +;;;msg1i db "Moving Strings",LF,0 +;;;msg2 db "About to Relocate Pointers",LF,0 +;;;msg3 db "Complementing GC Bits",LF,0 +;;;msg4 db "About to Sweep",LF,0 +data ends + +prog segment byte public 'PROG' + assume CS:PGROUP + extrn %allocbl:far ; "alloc_block" linkage routine + +;************************************************************************ +;* Far Linkage to SUM_SPACE * +;************************************************************************ +%sumspac proc far + pop ret_sav1 + pop ret_sav2 + extrn sum_spac:near + call sum_spac + push ret_sav2 + push ret_sav1 + ret +%sumspac endp + +;************************************************************************ +;* Far Linkage to GCSWEEP * +;************************************************************************ +%gcsweep proc far + pop ret_sav1 + pop ret_sav2 + extrn gcsweep:near + call gcsweep + push ret_sav2 + push ret_sav1 + ret +%gcsweep endp + +IFDEF EXPMEM + +;************************************************************************ +;* Far Linkage to GCCLEAN * +;************************************************************************ +%gcclean proc far + pop ret_sav1 + pop ret_sav2 + extrn gcclean:near + call gcclean + push ret_sav2 + push ret_sav1 + ret +%gcclean endp + +ENDIF + +;************************************************************************ +;* ***Temporary Long Linkage to PRINTF*** * +;************************************************************************ + public %printf,%sdebug +%printf proc far + pop ret_sav1 + pop ret_sav2 + extrn printf:near + call printf + push ret_sav2 + push ret_sav1 + ret +%printf endp + +;************************************************************************ +;* ***Temporary Long Linkage to SDEBUG*** * +;************************************************************************ +%sdebug proc far + pop ret_sav1 + pop ret_sav2 + extrn sdebug:near + call sdebug + push ret_sav2 + push ret_sav1 + ret +%sdebug endp + +prog ends + +PROGX segment byte public 'PROGX' + assume CS:XGROUP + + extrn srelocat:near ; pointer relocation routine + extrn toggleGC:near ; complement GC bits + +;************************************************************************ +;* Garbage Collection -- Compaction Phase * +;************************************************************************ +sq_args struc +sq_free dw NUMPAGES dup (?) ; amount of free space within each page +sq_plist dw NUMPAGES dup (?) ; list of pages +sq_BP dw ? ; caller's BP register + dw ? ; caller's ES register + dd ? ; return address (far call) + dw ? ; return address (near call) +sq_args ends + +%squish proc far + push ES ; save caller's ES register + push BP ; and BP register + sub SP,offset sq_BP ; allocate local storage + mov BP,SP ; and establish addressability + +; Compute the amount of free space in each page + lea BX,[BP].sq_free ; load address of size array + push BX ; and push as argument to "sum_space" + call %sumspac ; determine available space in each page + mov SP,BP ; drop argument from TIPC's stack + +; Initialize table of page numbers + mov AX,DS ; make ES point to the data + mov ES,AX ; segment + mov CX,NUMPAGES ; load page count + lea DI,[BP].sq_plist ; load address of page number table + xor AX,AX ; initialize page number index to zero +pt_loop: stosw ; set page number to current position + add AX,WORDINCR ; increment page index + loop pt_loop ; process all page numbers + +; Reset the similar page type chain headers + mov CX,NUMTYPES + mov AX,END_LIST + mov DI,offset pagelist +rep stosw + +; Sort list of pages according to size available + mov DX,DEDPAGES*WORDINCR +sort_nxt: mov SI,DX + mov DI,[BP].sq_plist+[SI] + mov AX,[BP].sq_free+[DI] ; load amount of space in base page +sort_mor: add SI,WORDINCR ; increment inner loop index + mov DI,[BP].sq_plist+[SI] ; load page index + cmp AX,[BP].sq_free+[DI] ; has current page less space? + jbe sort_no ; if not, jump + mov AX,[BP].sq_free+[DI] ; load size of smaller free space + mov DI,DX + mov CX,[BP].sq_plist+[SI] ; exchange base page index + xchg CX,[BP].sq_plist+[DI] ; with current page + mov [BP].sq_plist+[SI],CX ; index +sort_no: cmp SI,NUMPAGES*WORDINCR-WORDINCR ; is inner loop complete? + jl sort_mor ; if not, jump + add DX,WORDINCR ; increment outer loop index + cmp DX,NUMPAGES*WORDINCR-WORDINCR ; is outer loop complete? + jl sort_nxt ; if not, keep on loopin' + +; Update the similar page type chains + mov DI,DEDPAGES*WORDINCR +spt_loop: mov SI,[BP].sq_plist+[DI] + test attrib+[SI],NOMEMORY + jnz spt_end + mov BX,ptype+[SI] + mov AX,pagelist+[BX] + mov pagelink+[SI],AX + mov AX,SI + CORRPAGE AX + mov pagelist+[BX],AX +spt_end: add DI,WORDINCR + cmp DI,NUMPAGES*WORDINCR + jl spt_loop + +IFDEF EXPMEM + call %gcclean ; Clean out Emm Page table for compaction +ENDIF + +; Note: If printing messages, make ES point to the data segment +;;; mov AX,DS ;* Make ES point to the data +;;; mov ES,AX ;* segment + +; Compact List Cells +;;; mov AX,offset msg1a ;* +;;; push AX ; * print message indicating we're +;;; call %printf ;* compacting list cells + call sq_list + +; Compact Flonums +;;; mov AX,offset msg1b ;* +;;; push AX ; * print message indicating we're +;;; call %printf ;* compacting flonums + call sq_flo + +; Compact Bignums +;;; mov AX,offset msg1c ;* +;;; push AX ; * print message indicating we're +;;; call %printf ;* compacting bignums + mov AX,BIGTYPE*2 ; load type code index for bignums + push AX ; and push as argument to "sq_var" + call sq_var + mov SP,BP ; drop arguments from stack + +; Compact Closures +;;; mov AX,offset msg1d ;* +;;; push AX ; * print message indicating we're +;;; call %printf ;* compacting closures + mov AX,CLOSTYPE*2 ; load type code index for closures + push AX ; and push as argument to "sq_var" + call sq_var + mov SP,BP ; drop arguments from stack + +; Compact Code Blocks +;;; mov AX,offset msg1e ;* +;;; push AX ; * print message indicating we're +;;; call %printf ;* compacting code blocks + mov AX,CODETYPE*2 ; load type index for code blocks + push AX ; and push as argument to "sq_var" + call sq_var + mov SP,BP ; drop arguments from stack + +; Compact Vectors +;;; mov AX,offset msg1f ;* +;;; push AX ; * print message indicating we're +;;; call %printf ;* compacting vectors + mov AX,VECTTYPE*2 ; load type index for vectors + push AX ; and push as argument to "sq_var" + call sq_var + mov SP,BP ; drop arguments from stack + +; Compact Continuations +;;; mov AX,offset msg1g ;* +;;; push AX ; * print message indicating we're +;;; call %printf ;* compacting continuations + mov AX,CONTTYPE*2 ; load type index for continuations + push AX ; and push as argument to "sq_var" + call sq_var + mov SP,BP ; drop arguments from stack + +;;; Note: Let's not compact symbols for now. There are a few "special" +;;; symbols which mess things up in the runtime support if they +;;; move. Notably, CONSOLE_ and QUOTE_reg(?) +;;;; Compact Symbols +;;; mov AX,offset msg1h ;* +;;; push AX ; * print message indicating we're +;;; call %printf ;* compacting symbols +;;; mov AX,SYMTYPE*2 ; load type index for symbols +;;; push AX ; and push as argument to "sq_var" +;;; call sq_var +;;; mov SP,BP ; drop arguments from stack + +; Compact Strings +;;; mov AX,offset msg1i ;* +;;; push AX ; * print message indicating we're +;;; call %printf ;* compacting strings + mov AX,STRTYPE*2 ; load type index for strings + push AX ; and push as argument to "sq_var" + call sq_var + mov SP,BP ; drop arguments from stack + +; Relocate all moved pointers +;;; mov AX,offset msg2 ;* +;;; push AX ; * print a message that we're about +;;; call %printf ;* to perform pointer relocation + call srelocat ; relocate all pointers + +; Toggle the GC bits used to denote forwarding +;;; mov AX,offset msg3 ;* +;;; push AX ; * print a message that we're +;;; call %printf ; * complementing the GC bits + call toggleGC ; complement the GC (forwarding) bits + +IFDEF EXPMEM + call %gcclean ; Clean out Emm Page table +ENDIF + +; Invoke the "sweep" portion of the garbage collector to reclaim memory +;;; mov AX,offset msg4 ;* +;;; push AX ; * print a message that it's +;;; call %printf ; * "sweep" time + call %gcsweep ; reclaim all freed memory + +; Return to caller + mov SP,BP ; deallocate stack temporaries + add SP,offset sq_BP ; release local storage + pop BP ; restore caller's BP register + pop ES ; and ES register + ret ; return +%squish endp + +;************************************************************************ +;* Macro Support for List/Flonum Compaction * +;* * +;* Register usage during "move" phase of this routine: * +;* AX - backward chain header (destination page index) * +;* BX - (scratch register) * +;* CX - word count for block move * +;* DX - forward chain header (source page index) * +;* DS:[SI] - source list cell * +;* ES:[DI] - destination list cell * +;************************************************************************ +sql_arg struc +sql_rev dw NUMPAGES dup (?) ; reversed linked list of list pages +sql_bptr dw ? ; reversed list header +sql_BP dw ? ; caller's BP + dw ? ; caller's ES + dw ? ; return address +sql_type dw ? ; type code index (for variable len objects) +sql_arg ends + +sq_L_F macro uppercase,lowercase + local sql_go,sql_010,sql_020,sql_025,sql_030,sql_035 + local sql_040,sql_050,sql_060,sql_070,sql_done,sql_ret + push ES ; save caller's ES + push BP ; save caller's BP + sub SP,offset sql_BP ; allocate local storage + mov BP,SP ; establish local addressability + +; Create a reverse order linked list of pages + lea BX,[BP].sql_rev ; load addr of reverse linked list array + mov AX,uppercase&TYPE*2 ; load type code + pushm ; push type code, array addr as arguments + call sq_rever ; create the reverse linked list + mov SP,BP ; drop arguments off TIPC's stack + cmp AX,END_LIST ; is list of pages empty? + jne sql_go ; if list non-empty, continue (jump) + jmp sql_ret ; if empty list, return +sql_go: ADJPAGE AX ; convert list header to page index value + +; Move list cells from least dense pages to most dense pages + mov DX,lowercase&page ; load page number of least dense + ADJPAGE DX ; page and convert to page index + mov BX,DX ; copy page index into BX + push DS ; save DS register + +; * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * +; * * * WARNING: The DS Register Doesn't Point to the Data Segment * * * +; * * * in the code which follows: * * * +; * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * + + %LoadPage0 DS,BX ; load paragraph address of source page + + mov SI,-uppercase&SIZE ; load source page index + jmp short sql_020 ; jump + +; Follow backward chain to get new destination page +sql_010: mov BX,AX ; set next available cell address to + mov SS:nextcell+[BX],DI ; END_LIST + mov BX,BP ; calculate address of current element in + add BX,AX ; reversed page list + mov AX,SS:[BX].sql_rev ; load next page in backward chain + ADJPAGE AX ; convert page number to page index +sql_020: cmp AX,DX ; another destination page available? + jne sql_025 + jmp sql_done ; if source page = destination page, jump +sql_025: + mov BX,AX ; copy destination page index to BX + + %LoadPage1 ES,BX ; load paragraph address of dest page + mov DI,SS:nextcell+[BX] ; load free cell header +IFDEF EXTMEM + mov BX,DX ; reload dest. page so it won't ever + %LoadPage0 DS,BX ; get swapped out +ENDIF + +; Make sure a cell is available in the destination page +sql_030: cmp DI,END_LIST + je sql_010 + +; Is there a cell to move from the source page? +sql_040: mov BX,DX + mov BX,SS:psize+[BX] ; load the page size and + sub BX,uppercase&SIZE ; compute end of page boundary +sql_050: add SI,uppercase&SIZE ; increment source page offset + cmp SI,BX ; end of source page? + ja sql_070 ; if end of page, jump + cmp [SI].car_page,0FFh ; is this cell referenced? + je sql_050 ; if an unreferenced cell, jump + +; Move the cell from source page to destination page +sql_060: mov BX,ES:[DI].car ; load offset of next free cell in dest page +IF uppercase&SIZE - (uppercase&SIZE/2)*2 + mov CX,uppercase&SIZE +rep movsb +ELSE + mov CX,uppercase&SIZE/WORDINCR ; load number of words to move +rep movsw ; copy the contents of the list cell +ENDIF + sub SI,uppercase&SIZE ; back up the source and destination + sub DI,uppercase&SIZE ; pointers +IFIDN , + mov [SI].car_page,AL ; store a forwarding pointer into the car + mov [SI].car,DI ; field of the source list cell +ELSE +IFIDN , + mov [SI].flo_data,AL + mov word ptr [SI].flo_data+1,DI +ELSE + OOPS invalid data type: uppercase +ENDIF +ENDIF + or byte ptr [SI].&lowercase&_gc,GC_BIT ; set GC bit to indicate + ; forward + mov DI,BX ; copy next free cell offset into DI + jmp sql_030 ; process next move + +; Follow forward pointer to get a next source page +sql_070: mov BX,DX ; copy forward chain header to BX + mov DX,SS:pagelink+[BX] ; load next page in forward chain + ADJPAGE DX ; convert page number to page index + mov BX,DX + + %LoadPage0 DS,BX ; load paragraph address of source page +IFDEF EXTMEM + mov BX,AX ; reload dest. page so it won't ever + %LoadPage1 ES,BX ; get swapped out +ENDIF + + mov SI,-uppercase&SIZE ; initialize source page index + cmp AX,DX ; does source page = destination page? + je sql_035 + jmp sql_040 ; if not, keep on moving cells (jump) +sql_035: +; No more cells to move-- update destination page available cell header + mov BX,AX ; update next available cell pointer + mov SS:nextcell+[BX],DI ; in the destination page + +; * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * +; * * * WARNING: The DS Register Doesn't Point to the Data Segment * * * +; * * * in the code above * * * +; * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * + +; Copying complete +sql_done: pop DS ; restore data segment register (DS) + +sql_ret: mov SP,BP ; clean up TIPC's stack + add SP,offset sql_BP ; deallocate local storage + pop BP ; restore caller's BP + pop ES ; restore caller's ES + ret ; return to caller + endm + +;************************************************************************ +;* List Cell Compaction * +;************************************************************************ +sq_list proc near + sq_L_F LIST,list +sq_list endp + +;************************************************************************ +;* Flonum Compaction * +;************************************************************************ +sq_flo proc near + sq_L_F FLO,flo +sq_flo endp + +;************************************************************************ +;* Variable Length Object Compaction * +;* * +;* Register usage during "move" phase of this routine: * +;* AX - backward chain header (destination page index) * +;* BX - (scratch register) * +;* CX - word count for block move * +;* DX - forward chain header (source page index) * +;* DS:[SI] - source list cell * +;* ES:[DI] - destination list cell * +;* * +;* Notes: * +;* * +;* 1. Any object which is less than 6 bytes in length cannot be moved * +;* because there's no place to put a forwarding pointer. If a * +;* page is encountered with such an object (e.g., a zero length * +;* vector) that object, and the remaining objects in that page are * +;* not copied. Processing continues with the next source page. * +;* * +;* 2. The current code block cannot be relocated, since the offset * +;* into the current code block is held in register SI in most of * +;* the code of the Scheme Virtual Machine emulator. Since it is * +;* not possible to update this offset, the page containing the * +;* current code block is skipped, if encountered during * +;* compaction. * +;************************************************************************ +sq_var proc near + push ES ; save caller's ES + push BP ; save caller's BP + sub SP,offset sql_BP ; allocate local storage + mov BP,SP ; establish local addressability + +; Create a reverse order linked list of pages + lea BX,[BP].sql_rev ; load addr of reverse linked list array + pushm <[BP].sql_type,BX> ; push type code, array addr as arguments + call sq_rever ; create the reverse linked list + mov SP,BP ; drop arguments off TIPC's stack + cmp AX,END_LIST ; is list of pages empty? + jne sqv_020 ; if list non-empty, continue (jump) +sqv_010: jmp sqv_ret ; if empty list, return +sqv_020: ADJPAGE AX ; convert list header to page index value + mov [BP].sql_bptr,AX ; save destination list header + +; Move list cells from least dense pages to most dense pages + mov BX,[BP].sql_type ; load type index for page type + mov DX,pagelist+[BX] ; load page number of least dense + ADJPAGE DX ; page and convert to page index + cmp AX,DX ; destination page available? + je sqv_010 ; if source page = destination page, jump + mov BX,DX ; copy page index into BX + push DS ; save DS register + +; * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * +; * * * WARNING: The DS Register Doesn't Point to the Data Segment * * * +; * * * in the code which follows: * * * +; * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * + + cmp DL,byte ptr CB_pag ; does page contain current code block? + je sqv_052 ; if so, skip it +IFDEF EXPMEM + cmp psize+[BX],MIN_PAGESIZE ; page size greater than minimum? + jne sqv_052 +ENDIF + %LoadPage0 DS,BX ; load paragraph address of source page +;;; mov DS,pagetabl,[BX] ; load paragraph address of source page + xor SI,SI ; load source page index + +; Is there an object to move from the source page? +sqv_040: mov BX,DX + mov BX,SS:psize+[BX] ; load the page size and + sub BX,BLK_OVHD ; compute end of page boundary +sqv_050: cmp SI,BX ; end of source page? + ja sqv_052 ; if end of page, jump + cmp [SI].car_page,FREETYPE ; is this object referenced? + jne sqv_060 ; if a referenced object, jump + add SI,[SI].vec_len + jmp sqv_050 + +sqv_052: jmp sqv_070 ; process next source page + +; Find next possible destination page +sqv_054: mov BX,AX + add BX,BP + mov AX,SS:[BX].sql_rev + ADJPAGE AX + cmp AX,DX + jne sqv_061 + jmp sqv_done + +; Find a block into which to move the referenced object +sqv_060: mov CX,[SI].vec_len ; load length of object + cmp CX,0 ;;; check for small string + jge sqv_001 + mov CX,BLK_OVHD+PTRSIZE ;;; get the right value +sqv_001: cmp CX,BLK_OVHD+PTRSIZE ; is object "too small" to relocate? + jae sqv001 + jmp sqv_070 ; if "too small", abandon this page +sqv001: mov AX,[BP].sql_bptr ; load destination page list header +sqv_061: mov BX,AX ; copy index for destination page +IFDEF EXPMEM + cmp psize+[BX],MIN_PAGESIZE ; page size greater than minimum? + jne sqv_054 +ENDIF + %LoadPage1 ES,BX ; load paragraph address of dest page +IFDEF EXTMEM + %LoadPage0 DS,DX ; reload src page so it won't get swapped out +ENDIF + xor DI,DI ; page and initialize its index pointer + mov BX,SS:psize+[BX] ; load page size and + sub BX,BLK_OVHD ; adjust for boundary check + jmp short sqv_064 ; jump over increment +sqv_062: cmp ES:[DI].vec_len,0 ;;; check for small string + jge sqv_002 + add DI,BLK_OVHD+PTRSIZE ;;; add the exact length + jmp sqv_064 +sqv_002: add DI,ES:[DI].vec_len ; advance destination page index +sqv_064: cmp DI,BX ; end of page? + ja sqv_054 ; if end of page, jump + cmp ES:[DI].vec_type,FREETYPE ; free block? + jne sqv_062 ; if not a free block, keep looking (jump) +; Free block found-- is it big enough? + cmp CX,ES:[DI].vec_len + ja sqv_062 + je sqv_068 ; if an exact fit, jump + sub CX,ES:[DI].vec_len + neg CX + cmp CX,BLK_OVHD + jge sqv_066 + mov CX,[SI].vec_len + cmp CX,0 ;;; check for small string + jge sqv_062 + mov CX,BLK_OVHD+PTRSIZE ;;; get the right value + jmp sqv_062 +sqv_066: cmp [SI].vec_len,0 ;;; check for small string + jge sqv_003 + add DI,BLK_OVHD+PTRSIZE ;;; add the right value + jmp sqv_004 +sqv_003: add DI,[SI].vec_len +sqv_004: mov ES:[DI].vec_type,FREETYPE + mov ES:[DI].vec_len,CX + mov CX,[SI].vec_len + cmp CX,0 ;;; check for small string + jge sqv_005 + mov CX,BLK_OVHD+PTRSIZE +sqv_005: sub DI,CX + +; Move the cell from source page to destination page +sqv_068: mov BX,CX ; save the number of bytes moved +rep movsb ; copy object from source page to dest page + sub SI,BX ; back up the source and destination + sub DI,BX ; pointers + mov [SI].vec_page,AL ; store a forwarding pointer into the car + mov [SI].vec_disp,DI ; field of the source object + or byte ptr [SI].vec_gc,GC_BIT ; set GC bit to indicate forward + add SI,BX ; advance source page index to next object +sqv_069: jmp sqv_040 ; process next move + +; Follow forward pointer to get a next source page +sqv_070: mov BX,DX ; copy forward chain header to BX + mov DX,SS:pagelink+[BX] ; load next page in forward chain + ADJPAGE DX ; convert page number to page index + cmp AX,DX ; source = destination? ;rb for tc + je sqv_done ; yes, jump ;rb for tc + cmp DL,SS:byte ptr CB_pag ; current code block in this page? + je sqv_070 ; we can't relocate the current code block + mov BX,DX +IFDEF EXPMEM + cmp psize+[BX],MIN_PAGESIZE ; page size greater than minimum? + jne sqv_070 +ENDIF + %LoadPage0 DS,BX ; load paragraph address of source page +IFDEF EXTMEM + %LoadPage1 ES,AX ; reload dest page so it won't get swapped +ENDIF + xor SI,SI ; initialize source page index + cmp AX,DX ; does source page = destination page? + jne sqv_069 ; if not, keep on moving objects (jump) + +; * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * +; * * * WARNING: The DS Register Doesn't Point to the Data Segment * * * +; * * * in the code above * * * +; * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * + +; Copying complete +sqv_done: pop DS ; restore data segment register (DS) + +sqv_ret: mov SP,BP ; clean up TIPC's stack + add SP,offset sql_BP ; deallocate local storage + pop BP ; restore caller's BP + pop ES ; restore caller's ES + ret ; return to caller +sq_var endp + +;************************************************************************ +;* Local Support-- Create Reverse Linked List * + +;* * +;* Purpose: To create a reversed copy of the similar page list for * +;* pages of a given type. * +;* * +;* Calling Sequence: header = sq_rever(dest_array, type_index) * +;* header = header pointer of reversed list. * +;* dest_array = array to hold the pointers of the reversed * +;* linked list. * +;* type_index = type index (type*2) of the page type for * +;* which the similar page linked list is * +;* to be reversed (e.g., LISTTYPE*2 causes * +;* the linked list for list cell pages to * +;* be reversed. * +;************************************************************************ +sqr_args struc + dw ? ; caller's BP + dw ? ; return address +sqr_ary dw ? ; pointer to reversed list array +sqr_typ dw ? ; type code for desired page type +sqr_args ends + +sq_rever proc near + push BP ; save caller's BP + mov BP,SP ; establish addressability + mov BX,[BP].sqr_ary ; load address of destination array + mov SI,[BP].sqr_typ ; load type code for list to reverse + mov SI,pagelist+[SI] ; load list header to appropriate page type + mov AX,END_LIST ; load an end of list indicator +sqr_loop: cmp SI,END_LIST ; end of list? + je sqr_ret ; if end of list, return + mov DX,SI ; save current page number in DX + ADJPAGE SI ; convert page number to page index + mov [BX]+[SI],AX ; store prev page number into reversed array + mov SI,pagelink+[SI] ; fetch next page in linked list + mov AX,DX ; prev page number <- current page number + jmp sqr_loop ; continue 'til end of list +sqr_ret: pop BP ; restore caller's BP + ret ; return with reversed list header in AX +sq_rever endp + +PROGX ends + +prog segment byte public 'PROG' + assume CS:PGROUP +;************************************************************************ +;* Long Linkage to gcsquish * +;* * +;* Note: The lines which are commented out in the following code were * +;* used to print the "* compacting memory *" message in the * +;* who-line. Since it's a real pain in the a.. to allow the * +;* user to change the GC messages, it was decided that no * +;* message was the best way to go. * +;************************************************************************ + public gcsquish +gcsquish proc near + push ES ; save caller's ES register + push BP ; save caller's BP register + mov BP,SP + mov AX,DS ; make sure ES points to the data segment + mov ES,AX + C_call gc_on ; light up the "garbage collecting" message +;;; mov AX,offset msg ; load address of compaction message +;;; push AX ; and push as argument +;;; C_call who_writ ; display "compacting memory" message +;;; mov SP,BP ; drop argument from stack + call %squish ; perform memory compaction + C_call gc_off ; reset the garbage collection message + pop BP ; restore caller's BP + pop ES ; restore caller's ES + ret ; return to caller +gcsquish endp + +prog ends + end + \ No newline at end of file diff --git a/srch_str.asm b/srch_str.asm new file mode 100644 index 0000000..7f0d8b4 --- /dev/null +++ b/srch_str.asm @@ -0,0 +1,1359 @@ +; =====> SRCH_STR.ASM +;*************************************** +;* TIPC Scheme Runtime Support * +;* String Search Capabilities * +;* * +;* (C) Copyright 1985 by Texas * +;* Instruments Incorporated. * +;* All rights reserved. * +;* * +;* Date Written: 21 July 1985 * +;* Last Modification: 17 October 1985 * +;*************************************** + include scheme.equ + include pcmake.equ + include sinterp.arg +IFDEF PROMEM + include rpc.equ + include xli_pro.mac + include realio.equ + .286c +ENDIF + +DGROUP group data +XGROUP group PROGX +PGROUP group prog + +MSDOS equ 021h +TI_CRT equ 049h +IBM_CRT equ 010h + +; Definitions for control characters +CTL_A equ 1 +CTL_I equ 9 +CTL_Z equ 26 + +data segment word public 'DATA' + assume DS:DGROUP +IFDEF PROMEM +;from pro2real.asm + extrn REAL_BUF_SELECTOR:word,REAL_BUF_TOP:word,RPC_HANDLE:byte +ENDIF +ret_sav1 dw 0 ; return address save area +ret_sav2 dw 0 ; return address save area +m_srch_f db "SUBSTRING-FIND-NEXT-CHAR-IN-SET",0 +m_srch_b db "SUBSTRING-FIND-PREVIOUS-CHAR-IN-SET",0 +m_st_ln db "STRING-LENGTH",0 +m_mk_str db "MAKE-STRING",0 +m_stapnd db "%STRING-APPEND",0 +m_reifs db "%REIFY-STACK",0 +m_reifsb db "%REIFY-STACK!",0 +m_st_dsp db "%SUBSTRING-DISPLAY",0 +m_opnd dw INVALID_OPERAND_ERROR ; numeric error code +m_one dw 1 ; a constant "one" (1) +data ends + +prog segment byte public 'PROG' + assume CS:PGROUP + extrn %allocbl:far ; "alloc_block" linkage routine + extrn next:far ; Interpreter's "next instruction" point + extrn next_PC:far ; Interpreter's "next instruction" point + extrn sch_err:far ; Linkage to Scheme debugger +;************************************************************************ +;* Far Linkage to "set_src_err" * +;************************************************************************ + public %set_src +%set_src proc far + pop ret_sav1 + pop ret_sav2 + push DS ; make ES point to the current data segment + pop ES + extrn set_src_:near + call set_src_ + push ret_sav2 + push ret_sav1 + ret +%set_src endp + +;************************************************************************ +;* Far Linkage to "set_numeric_error" * +;************************************************************************ + public %set_num +%set_num proc far + pop ret_sav1 + pop ret_sav2 + push DS ; make ES point to the current data segment + pop ES + extrn set_nume:near + call set_nume + push ret_sav2 + push ret_sav1 + ret +%set_num endp + +;************************************************************************ +;* Far Linkage to "dissamble" * +;************************************************************************ + public %disasse +%disasse proc far + pop ret_sav1 + pop ret_sav2 + push DS ; make ES point to the current data segment + pop ES + extrn disassem:near + call disassem + push ret_sav2 + push ret_sav1 + ret +%disasse endp + +;************************************************************************ +;* Far Linkage to "get_port" * +;************************************************************************ + public %getport +%getport proc far + pop ret_sav1 + pop ret_sav2 + push DS ; make ES point to the current data segment + pop ES + extrn get_port:near + call get_port + push ret_sav2 + push ret_sav1 + ret +%getport endp + +prog ends + +PROGX segment byte public 'PROGX' + assume CS:XGROUP + + extrn CRT_DSR:far + +;************************************************************************ +;* Substring-Find-Next-Char-in-Set * +;************************************************************************ +srch_arg struc +strt_off dw ? ; starting offset (16 bit positive integer) +end_off dw ? ; ending offset (16 bit positive integer) +lngth dw ? ; number of characters in source string +result dw ? ; index of character matched + +; Note: the following two entries are order dependent +str_beg dw ? ; beginning offset of string +str_DS dw ? ; segment register value for string + +srch_BP dw ? ; caller's BP + dw ? ; caller's ES + dd ? ; return address (far) + dw ? ; return address (near) +str_reg dw ? ; register containing string +strt_reg dw ? ; register containing substr starting offset +end_reg dw ? ; register containing substr ending offset +cs_reg dw ? ; register containing charset string +srch_arg ends + +srch_str proc far + +%srchprv label far + mov CX,1 ; set search direction = backward + jmp short srch_go ; go to common processing code + +; Long Branch to Source Error Support +srch_er1: jmp srch_err + +%srchnxt label far + xor CX,CX ; set search direction = forward + +srch_go: push ES ; save caller's ES register + push BP ; save caller's BP register + sub SP,offset srch_BP ; allocate local storage + mov BP,SP ; establish addressability of local data + +; Validate Source String Argument + mov BX,[BP].str_reg ; load address of string register + mov SI,[BX].C_page ; and load string's page number + cmp byte ptr ptype+[SI],STRTYPE*2 ; is source string a string? + jne srch_er1 ; if not a string, error (jump) + %LoadPage ES,SI +;;; mov ES,pagetabl+[SI] ; load string's paragraph address + mov SI,[BX].C_disp ; load displacement of string + mov AX,ES:[SI].str_len ; load length of string + cmp AX,0 ;;; check length of string + jge srch_01 + add AX,PTRSIZE + jmp srch_02 +srch_01: sub AX,BLK_OVHD ; and compute number of characters in it +srch_02: mov [BP].lngth,AX ; save string length for further testing + add SI,BLK_OVHD ; advance string start to first character + mov [BP].str_beg,SI ; save starting character offset + mov [BP].str_DS,ES ; and segment register pointer + +; Validate Starting Offset Argument + mov BX,[BP].strt_reg ; load address of starting offset regsiter + call get_num ; obtain the integer value + jc srch_er1 ; if carry set, error + mov [BP].strt_off,AX ; and save it for future use + +; Validate Ending Offset Argument + mov BX,[BP].end_reg ; load address of ending offset register + call get_num ; obtain the integer value + jc srch_er1 ; if carry set, error + cmp [BP].strt_off,AX ; is starting offset greater than ending? + ja srch_er1 ; if so, invalid substring range (jump) + cmp AX,[BP].lngth ; test ending offset against string length + ja srch_er1 ; if ending offset too big, error (jump) + mov [BP].end_off,AX ; save ending offset for future use + +; Validate Charset String Argument + mov BX,[BP].cs_reg ; load number of register holding charset + mov DI,[BX].C_page ; load page number of charset pointer + cmp byte ptr ptype+[DI],STRTYPE*2 ; this is a sting, isn't it? + jne char_p ; if not a string, error (jump) + %LoadPage ES,DI +;;; mov ES,pagetabl+[DI] ; load paragraph address of string + mov DI,[BX].C_disp ; load displacement of string in page + mov DX,ES:[DI].str_len ; load length of string object + cmp DX,0 ;;; check length of string + jge srch_03 + add DX,PTRSIZE + jmp srch_04 +srch_03: sub DX,BLK_OVHD ; compute number of characters in charset +srch_04: add DI,BLK_OVHD ; advance string pointer past block header + jmp short go +char_p: cmp DI,SPECCHAR*2 ; is charset argument a single character? + je char_p0 ; Yes, continue + jmp srch_er1 ; No, error (jump) + +; Single character search-- optimize it +char_p0: mov AL,byte ptr [BX].C_disp + les DI,dword ptr [BP].str_beg + mov DX,CX ; save direction indicator in DX + mov CX,[BP].end_off ; compute length of search string + sub CX,[BP].strt_off + je not_fnd1 ; if search length is zero, return 'nil + cmp DX,0 + jne b_ward ; if backward, jump +; search for single character in forward direction + add DI,[BP].strt_off ; compute address of start of substring +repne scasb ; search for single character + jne not_fnd1 ; character found? If so, jump + dec DI ; fix up ending index + jmp short over +; search for single character in backward direction +b_ward: add DI,[BP].end_off ; compute address of end of substring + dec DI + std ; set search direction to be backwards +repne scasb ; search for single character + cld ; reset "direction" flag to go forwards + jne not_fnd1 ; if search length is zero, return 'nil + inc DI ; fix up ending index +over: mov SI,DI ; copy character address to SI + sub SI,[BP].str_beg ; and compute found character's address + jmp short found ; return index to found character + +; Determine whether string search is forward or backward +go: push DS ; save the data segment address + cmp CX,0 ; in which direction are we to search? + je forward ; if CX=0, forward; else backward + +; Register Usage in Innermost Loop: +; DS:SI - pointer to next character in source string +; ES:DI - pointer to charset string +; AL - search character +; BX - ending offset (source string) +; CX - length of charset string +; DX - length of charset string (used to refresh CX) + +; Search Source String in a Backwards Direction + mov BX,[BP].str_beg ; compute ending offset for string + add BX,[BP].strt_off + lds SI,dword ptr [BP].str_beg ; load addr of string's beginning + add SI,SS:[BP].end_off ; and compute end of substring address + jmp short startb ; jump to initial entry point in loop + +loopb: sub DI,DX ; reset starting offset of charset string +startb: cmp SI,BX ; at beginning of substring? + jbe not_fnd ; if at end, jump + mov CX,DX ; reload charset string length + dec SI ; decrement source string index + mov AL,[SI] ; and load next character to test +repne scasb ; search charset for current character + jne loopb + pop DS ; restore DS to point to data segment + sub SI,[BP].str_beg ; compute index of current character + jmp short found ; current character found in charset + +; no characters found which appear in the charset +not_fnd: pop DS ; restore DS to current data segment +not_fnd1: xor AX,AX ; store #!false in the + mov BX,[BP].str_reg ; destination register + mov byte ptr [BX].C_page,AL + mov [BX].C_disp,AX + jmp short ret ; return to caller + +; Search Source String in a Forward Direction +forward: mov BX,[BP].str_beg ; compute ending offset for string + add BX,[BP].end_off + lds SI,dword ptr [BP].str_beg ; load addr of string's beginning + add SI,SS:[BP].strt_off ; and compute beginning of substring + jmp short start ; jump to initial entry point in loop + +loop: sub DI,DX ; reset starting offset of charset string +start: cmp SI,BX ; at end of source string? + jae not_fnd ; if at end, jump + mov CX,DX ; reload charset string length + lodsb ; load next character to test +repne scasb ; search charset for current character + jne loop + +; current character found in charset-- return offset of current character + pop DS ; restore DS to current data segment + sub SI,[BP].str_beg ; adjust offset of character found + dec SI +found: mov BX,[BP].str_reg ; load address of destination register + call ret_num ; convert offset to Scheme integer + +; return to caller +ret: xor AX,AX ; set completion code for normal return +ret1: add SP,offset srch_BP ; release local storage + pop BP ; restore the caller's BP register + pop ES ; restore the caller's ES register + ret ; return + +; error-- invalid operand to string search primitive +srch_err: pushm <[BP].cs_reg,[BP].end_reg,[BP].strt_reg,[BP].str_reg> + cmp CX,0 ; search forward or backward? + jne backward ; if backward search, jump + mov AX,offset m_srch_f + jmp short common +backward: mov AX,offset m_srch_b +common: mov BX,4 ; load VM argument count + pushm ; push args=4, name of instruction + call %set_src ; call set_src_err(...); + mov AX,-1 ; load "invalid operand" flag + mov SP,BP ; drop arguments off the TIPC's stack + jmp ret1 ; return to interpreter + +srch_str endp + +dumy_arg struc + dw ? ; caller's BP + dd ? ; return address (far linkage) + dw ? ; return address (near linkage) +arg1 dw ? ; register address for argument 1 +arg2 dw ? ; register address for argument 2 +arg3 dw ? ; register address for argument 3 +arg4 dw ? ; register address for argument 4 +dumy_arg ends + +;************************************************************************ +;* AL * +;* (string-length string) string-length d=s1 * +;* * +;* Purpose: Scheme Interpreter support for the "string-lengt" function.* +;************************************************************************ +%st_len proc far + push BP ; save the caller's BP register + mov BP,SP ; establish addressability for arguments +; validate the string argument + mov BX,[BP].arg1 ; load address of argument register + mov SI,[BX].C_page ; load the string's page number + cmp byte ptr ptype+[SI],STRTYPE*2 ; it is a string, isn't it? + jne st_l_err ; if not a string, error (jump) +; compute string length + %LoadPage ES,SI +;;; mov ES,pagetabl+[SI] ; load paragraph address of string's page + mov SI,[BX].C_disp ; load string's displacement + mov SI,ES:[SI].str_len ; load length field from string object + cmp SI,0 ;;; check length of string + jge str_010 + add SI,PTRSIZE + jmp str_020 +str_010: sub SI,BLK_OVHD ; and compute number of characters in it +; return string length as an integer +str_020: call ret_num ; create Scheme representation for integer +; return + xor AX,AX ; set error code for normal return +str_ret: pop BP ; restore the caller's BP register + ret ; return to caller +; ***error-- operand was not a string*** +st_l_err: mov AX,offset m_st_ln ; load text address for "STRING-LENGTH" + mov CX,1 ; indicate one operand + pushm ; push arguments for call + call %set_src ; call: set_src_err("STRING-LENGTH",1,arg1) + mov SP,BP ; drop arguments off stack + mov AX,-1 ; indicate error return + jmp str_ret ; return +%st_len endp + +;************************************************************************ +;* MAKE-STRING (MAKE-STRING LENGTH INIT-VAL) * +;* * +;* Purpose: Scheme Interpreter support for the "MAKE-STRING" function. * +;* * +;* Note: The maximum length of a PCS string is 2^16 - 3 (65,532) * +;* characters. * +;************************************************************************ +%makestr proc far + push BP ; save the caller's BP register + mov BP,SP ; establish addressability for arguments +; validate the length operand + mov BX,[BP].arg1 ; load address of reg containing length + call get_num ; get the value of the integer + jc mk_s_err ; error? if so, jump +; allocate the string object + mov CX,STRTYPE ; load the type code for a string + pushm ; push arguments for the call + call %allocbl ; call: alloc_block(arg1, STRTYPE, length) + mov SP,BP ; drop the arguments off the stack +; validate the initialization value + mov BX,[BP].arg2 ; load address of register with init value + mov SI,[BX].C_page ; load initialization value's page number + cmp SI,0 ; default initialization value (nil)? + jne mk_s_ch ; if not nil, check for character (jump) + mov AL," " ; use blank (" ") as default fill value + jmp short mk_s_in ; initialize the string +mk_s_ch: cmp SI,SPECCHAR*2 ; is initialization value a character? + jne mk_s_err ; if not a character or nil, error (jump) + mov AL,byte ptr [BX].C_disp ; load the value of the character +; initialize the string +mk_s_in: mov BX,[BP].arg1 ; load a pointer to the newly allocated + mov DI,[BX].C_disp + mov BX,[BX].C_page + %LoadPage ES,BX +;;; mov ES,pagetabl+[BX] + mov CX,[BP].arg3 ; load length of string object + add DI,BLK_OVHD ; advance string ptr to 1st char position +rep stosb ; propagate initval throughout string +; return to caller + xor AX,AX ; set the return code for a normal return +mk_s_ret: pop BP ; restore the caller's BP register + ret ; return +; ***error-- invalid operand to MAKE-STRING*** +mk_s_err: mov AX,offset m_mk_str ; load addr of "MAKE-STRING" text + mov BX,2 ; load argument count = 2 + pushm <[BP].arg2,[BP].arg1,BX,AX> + call %set_src ; set_src_err("MAKE-STRING",2,arg1,arg2) + mov SP,BP ; drop arguments off TIPC stack + mov AX,-1 ; indicate error return + jmp short mk_s_ret ; return +%makestr endp + +;************************************************************************ +;* (%str-append str1 start1 end1 {nil,char,str2} str3 start3 end3) * +;************************************************************************ +str_arg struc +start1 dw ? ; starting offset of first string +start3 dw ? ; starting offset of third string +len1 dw ? ; length of first string +len2 dw ? ; length of second string +len3 dw ? ; length of third string +str_BP dw ? ; caller's BP + dw ? ; caller's SI + dw ? ; caller's ES +reg7 dw ? ; address of 7th operand register +reg6 dw ? ; address of 6th operand register +reg5 dw ? ; address of 5th operand register +reg4 dw ? ; address of 4th operand register +reg3 dw ? ; address of 3rd operand register +reg2 dw ? ; address of 2nd operand register +reg_1 dw ? ; address of 1st operand register +str_arg ends + + public str_apnd +%strapnd proc far +str_err1: jmp str_err ; indirect jump to error code +; Load operands of this here instruction and compute register addresses +str_apnd: mov CX,7 ; load count of number of operands +str_ld: xor AX,AX ; clear AH + lods byte ptr ES:[SI] ; load register number of this operand + add AX,offset reg0 ; and compute the register's address + push AX ; save the register's address on the stack + loop str_ld ; continue until all operands processed +; Save registers and establish addressability of local storage + push ES ; save caller's ES register + push SI ; save caller's SI register + push BP ; save caller's BP register + sub SP,offset str_BP ; allocate local storage + mov BP,SP ; and establish addressability + +; Validate the First String's Starting Offset + mov BX,[BP].reg2 ; load address of start1 register + call get_num ; fetch value for start1 + jc str_err1 ; if error, jump + add AX,BLK_OVHD ; advance starting offset past block header + mov [BP].start1,AX ; save start1 offset +; Validate the First String's Ending Offset + mov BX,[BP].reg3 ; load address of end1 register + call get_num ; fetch value for end1 + jc str_err1 ; if error, jump + add AX,BLK_OVHD ; advance ending offset past block header +; Validate the First String Operand + mov BX,[BP].reg_1 ; load address of string1 register + mov SI,[BX].C_page ; load string's page number + cmp byte ptr ptype+[SI],STRTYPE*2 ; it is a string, isn't it? + jne str_err1 ; if not a string, error (jump) + %LoadPage ES,SI +;;; mov ES,pagetabl+[SI] ; load a pointer to the string + mov SI,[BX].C_disp + mov CX,ES:[SI].str_len ; ending offset past string end? + cmp CX,0 ;;; check length of string + jge str_01 + add CX,BLK_OVHD+PTRSIZE ;;; adjust the string length +str_01: cmp AX,CX + ja str_err1 ; if ending offset too big, error (jump) + sub AX,[BP].start1 ; is ending offset too small? + jb str_err1 ; if ending offset smaller than start, jump + mov [BP].len1,AX ; save length of substring1 + +; Validate the Third String's Starting Offset + mov BX,[BP].reg6 ; load address of start3 register + call get_num ; fetch value for start3 + jc str_err ; if error, jump + add AX,BLK_OVHD ; advance starting offset past block header + mov [BP].start3,AX ; save start3 offset +; Validate the Third String's Ending Offset + mov BX,[BP].reg7 ; load address of end3 register + call get_num ; fetch value for end3 + jc str_err ; if error, jump + add AX,BLK_OVHD ; advance ending offset past block header +; Validate the Third String Operand + mov BX,[BP].reg5 ; load address of string3 register + mov SI,[BX].C_page ; load string's page number + cmp byte ptr ptype+[SI],STRTYPE*2 ; it is a string, isn't it? + jne str_err ; if not a string, error (jump) + %LoadPage ES,SI +;;; mov ES,pagetabl+[SI] ; load a pointer to the string + mov SI,[BX].C_disp + mov CX,ES:[SI].str_len ; ending offset past string end? + cmp CX,0 ;;; check length of string + jge str_02 + add CX,BLK_OVHD+PTRSIZE ;;; adjust the string length +str_02: cmp AX,CX + ja str_err ; if ending offset too big, error (jump) + sub AX,[BP].start3 ; is ending offset too small? + jb str_err ; if ending offset smaller than start, jump + mov [BP].len3,AX ; save length of substring3 + +; Validate the "thing" to be inserted between string1 and string3 + mov BX,[BP].reg4 ; load register with said "thing" + mov SI,[BX].C_page ; load page number + cmp SI,NIL_PAGE*2 ; is object nil? + jne str_10 ; if not nil, jump +; The "thing" is nil-- indicate nothing to insert + mov [BP].len2,0 ; indicate zero length "thing" + jmp short str_30 ; continue processing + +; ***We interrupt this routine for some error support code*** +str_err: mov AX,offset m_stapnd + mov CX,7 + pushm <[BP].reg7,[BP].reg6,[BP].reg5,[BP].reg4,[BP].reg3> + pushm <[BP].reg2,[BP].reg_1,CX,AX> + call %set_src + mov SP,BP + add SP,offset str_BP + pop BP + pop SI + pop ES + jmp sch_err + +str_10: cmp SI,SPECCHAR*2 ; is "thing" a character? + jne str_20 ; if not a character, jump +; The "thing" is a character + mov [BP].len2,1 ; indicate length = 1 character + jmp short str_30 +str_20: cmp byte ptr ptype+[SI],STRTYPE*2 ; is "thing" a string? + jne str_err ; if not a string, error (jump) +; The "thing" is a string-- establish string length + %LoadPage ES,SI +;;; mov ES,pagetabl+[SI] ; load string page's paragraph address + mov SI,[BX].C_disp + mov AX,ES:[SI].str_len + cmp AX,0 ;;; check length of string + jge str_03 + add AX,PTRSIZE + jmp str_04 +str_03: sub AX,BLK_OVHD ; and compute number of characters in it +str_04: mov [BP].len2,AX ; save string length for further testing + +; All arguments OK, allocate the new string +str_30: mov AX,[BP].len1 ; compute the length of the new string + add AX,[BP].len2 + add AX,[BP].len3 + cmp AX,16383 ; is new string greater than max string size? + jg str_err ; Yes ... error + mov BX,STRTYPE ; load tag=string + mov CX,offset tmp_reg + pushm ; push arguments to call + call %allocbl + mov SP,BP ; drop arguments off the stack + mov DI,tmp_page ; load pointer to newly allocated string + %LoadPage0 ES,DI +;;; mov ES,pagetabl+[DI] + mov DI,tmp_disp ; pointer is now in ES:[DI] + add DI,BLK_OVHD ; advance pointer to 1st character location +; Move in data from all substrings + mov CX,[BP].len1 ; load length of string1 + mov BX,[BP].reg_1 ; load addr of register containing string 1 + mov SI,[BX].C_disp ; load string 1's offset + add SI,[BP].start1 ; add in offset of starting character + mov BX,[BX].C_page ; load page number + push DS ; save the data segment register + %LoadPage1 DS,BX +;;; mov DS,pagetabl+[BX] +;********************************************************************** +;* * * Warning: The data segment register (DS) does not point to * * * +;* * * the data segment in the code which follows * * * +;********************************************************************** +rep movsb ; copy string1 into new string + pop DS ; restore data segment register + + mov CX,[BP].len2 ; load length of string2 + cmp CX,0 ; any characters to move? + je str_60 ; if no characters, jump + mov BX,[BP].reg4 ; load addr of register with "thing" + mov SI,SS:[BX].C_disp ; load a pointer to "thing" + mov BX,SS:[BX].C_page + push DS ; Save data segment register + cmp BL,SPECCHAR*2 ; is "thing" a character? + jne str_40 ; if not a character, then a string (jump) + mov SI,[BP].reg4 ; load addr of register containing character + jmp short str_50 +str_40: %LoadPage1 DS,BX +;;; mov DS,SS:pagetabl+[BX] ; "thing" is a string-- load pointer + add SI,BLK_OVHD ; to it and advance to 1st character +str_50: +rep movsb ; copy string2 into new string + pop DS ; restore data segment register + +str_60: mov CX,[BP].len3 ; load length of string3 + mov BX,[BP].reg5 ; load addr of register containing string 3 + mov SI,SS:[BX].C_disp ; load string offset + add SI,[BP].start3 ; advance starting offset past block header + mov BX,SS:[BX].C_page ; load the string's page number and + push DS + %LoadPage1 DS,BX +;;; mov DS,SS:pagetabl+[BX] ; paragraph address +rep movsb ; copy string3 into new string + pop DS ; restore the data segment register +;********************************************************************** +;* * * Warning: The data segment register (DS) does not point to * * * +;* * * the data segment in the code above * * * +;********************************************************************** + +; Place pointer to new string into the destination register + mov DI,[BP].reg_1 ; load destination register address + mov AL,byte ptr tmp_page + mov byte ptr [DI].C_page,AL + mov AX,tmp_disp + mov [DI].C_disp,AX + +; Return + add SP,offset str_BP ; deallocate local storage + pop BP ; restore caller's BP + pop SI ; restore caller's SI + pop ES ; restore caller's ES + jmp next ; return to Scheme interpreter + +%strapnd endp + +;************************************************************************ +;* Reify(!)-Stack * +;* * +;* Purpose: To provide the ability to manipulate items on the Scheme * +;* runtime stack from Scheme. * +;* * +;* Description: The elements of the stack are referenced by providing * +;* the byte offset of the desired element as an index * +;* to the REIFY-STACK or REIFY-STACK! instruction. An * +;* index of -1 to REIFY-STACK is a request that the current* +;* stack frame pointer be returned. * +;************************************************************************ +r_stk struc +bang dw ? ; fetch/store indicator +r_stk_BP dw ? ; caller's BP + dd ? ; return address (far call) + dw ? ; return address (near call) +r_index dw ? ; register containing index; destination reg +r_value dw ? ; register containing value (for stores) +r_stk ends + +%reifyst proc far +; ***Error-- Invalid Index for REIFY-STACK(!) Instruction*** +reif_err: cmp CX,0 ; is this a fetch or store? + jne reif_e10 ; if store, jump + mov AX,offset m_reifs ; load text address for "REIFY-STACK" + mov BX,1 ; indicate 1 operand to this instruction + jmp short reif_e20 ; jump to common error code +reif_e10: mov AX,offset m_reifsb ; load text address for "REIFY-STACK!" + mov BX,2 ; indicate 2 operands to this instruction + push [BP].r_value ; and push second reigster operand +reif_e20: pushm <[BP].r_index,BX,AX> ; push arguments + call %set_src ; indicate source operand error + mov SP,BP ; drop arguments off the stack + mov AX,-1 ; load an error flag + jmp reif_rt1 ; return with error flag in AX + +; (REIFY-STACK! index value) ; entry point +%reifstb label far + mov CX,1 ; indicate a store operation + jmp short reif_go ; jump to common entry code + +; (REIFY-STACK index) ; entry point +%reifstk label far + xor CX,CX ; indicate a fetch operation + +reif_go: push BP ; save the caller's BP register + sub SP,offset r_stk_BP ; allocate local storage + mov BP,SP ; establish addressability for operands/data + +; Validate index + mov BX,[BP].r_index ; load address of register containing index + cmp CX,0 ; is this a REIFY-STACK operation? + jne reif_no ; if not, skip special check for -1 +; Check for an index of -1 indicating we need to return FP + cmp byte ptr [BX].C_page,SPECFIX*2 ; is index a fixnum? + jne reif_no ; if not a fixnum index, jump + cmp [BX].C_disp,07FFFh ; is index a -1? + jne reif_no ; if not -1, jump + mov AX,FP ; load FP's offset in stack buffer + add AX,BASE ; and add BASE to compute absolute offset + mov SI,AX ; copy quotient to SI + call ret_num ; convert element index to a Scheme integer + jmp reif_ret ; return the element index of FP +; Fetch the index value +reif_no: call get_num ; fetch the integer value + jc reif_err ; if not a valid index, jump + push AX ; save the byte offset + xor DX,DX ; convert to a double word (w/out sign ext) + mov BX,PTRSIZE ; load divisor + div BX ; divide by number of bytes/pointer + pop AX ; restore the byte index + cmp DX,0 ; is remainder zero? + jne reif_err ; if not a multiple of PTRSIZE, error (jump) + mov DX,BASE ; compute the current top of stack (TOS) + add DX,TOS ; offset + cmp AX,DX ; is index larger than TOS? + ja reif_err ; if so, error (jump) + +; Attempt to find the desired element in the stack buffer + cmp AX,BASE ; is BASE < element index? + jb reif_cnt ; if so, element is in previous stack segment + sub AX,BASE ; compute byte offset of desired element + add AX,offset S_stack ; compute offset in stack buffer + mov SI,AX ; and move offset into SI + mov AX,DS ; put data segment address into ES so that + mov ES,AX ; desired element is pointed to by ES:[SI] + jmp reif_do ; fetch/store the element + +; Find the element in a previous stack segment (a continuation object) +reif_cnt: mov BX,PREV_pag ; make ES:[SI] point to the previous + mov SI,PREV_dis ; stack segment continuation object + %LoadPage ES,BX +;;; mov ES,pagetabl+[BX] +; Follow stack segment chain until desired offset found +reif_lop: cmp AX,ES:[SI].con_base ; compare element index:continuation base + jae reif_fnd ; if offset > base, element in this segment + mov BL,ES:[SI].con_spag ; load pointer to previous stack segment + mov SI,ES:[SI].con_sdis ; into ES:[SI] + %LoadPage ES,BX +;;; mov ES,pagetabl+[BX] ; + jmp short reif_lop ; loop until desired segment found +; Element found in stack segment (continuation) object +reif_fnd: sub AX,ES:[SI].con_base ; subtrace off continuation's base + add SI,AX ; add entry's byte offset + add SI,offset con_data ; adjust for continuation header + +; Desired stack element address by ES:[SI]-- is this a fetch or store? +reif_do: cmp CX,0 ; test fetch/store flag + jne reif_st ; if a store, jump +; Fetch desired stack element + mov BX,[BP].r_index ; load address of destination register + mov AL,ES:[SI].car_page ; load page number of stack entry + mov byte ptr [BX].C_page,AL ; and store into destination register + mov AX,ES:[SI].car ; load displacement of stack entry + mov [BX].C_disp,AX ; and store into destination register + jmp short reif_ret +; Re-define desired stack element +reif_st: mov BX,[BP].r_value ; load add of register containing new value + mov AL,byte ptr [BX].C_page + mov ES:[SI].car_page,AL + mov AX,[BX].C_disp + mov ES:[SI].car,AX + +; return to caller +reif_ret: xor AX,AX ; indicate no error encountered +reif_rt1: add SP,offset r_stk_BP ; deallocate local storage + pop BP ; restore the caller's BP register + ret ; return to caller +%reifyst endp + +;************************************************************************ +;* AL AL AH AL AH * +;* (%SUBSTRING-DISPLAY string start end row-bias window) * +;* * +;* Purpose: Special support for displaying strings to the CRT for * +;* applications such as text editors. * +;************************************************************************ + +IFDEF PROMEM + +SD_BSIZE equ 100 ; buffer size +sd_args struc +; Warning: the following five (5) items are order dependent +sd_dummy dw ? ; extra for realio +sd_len dw ? ; #chars in following buffer +sd_buff db SD_BSIZE dup (?) ; string buffer +sd_text dw ? ; text attributes for window +sd_cursv dw ? ; cursor coordinate save area +; +sd_char db ? ; "saved" character +sd_streg dw ? ; string register address +sd_start dw ? ; substring's starting offset +sd_end dw ? ; substring's ending offset +sd_bias dw ? ; row bias +sd_cline dw ? ; cursor line number +sd_ccol dw ? ; cursor column number +sd_nline dw ? ; number of lines in the window +sd_ncols dw ? ; number of columns in the window +sd_ullin dw ? ; upper left corner line number +sd_ulcol dw ? ; upper left corner column number +sd_arg45 dw ? ; arguments 4,5 save area +sd_last dw ? ; last write flag +sd_linum db ? ; line number +; Warning: the following two (2) items are order dependent +sd_wn_SI dw ? ; pointer to window object, part 1 +sd_wn_ES dw ? ; pointer to window object, part 2 +; +sd_BP dw ? ; caller's BP +sd_args ends + +ELSE + +sd_args struc +sd_buff db 100 dup (?) ; string buffer +sd_char db ? ; "saved" character +sd_streg dw ? ; string register address +sd_start dw ? ; substring's starting offset +sd_end dw ? ; substring's ending offset +sd_bias dw ? ; row bias +sd_cline dw ? ; cursor line number +sd_ccol dw ? ; cursor column number +sd_nline dw ? ; number of lines in the window +sd_ncols dw ? ; number of columns in the window +sd_ullin dw ? ; upper left corner line number +sd_ulcol dw ? ; upper left corner column number +sd_text dw ? ; text attributes for window +sd_arg45 dw ? ; arguments 4,5 save area +sd_cursv dw ? ; cursor coordinate save area +sd_last dw ? ; last write flag +sd_linum db ? ; line number +; Warning: the following two (2) items are order dependent +sd_wn_SI dw ? ; pointer to window object, part 1 +sd_wn_ES dw ? ; pointer to window object, part 2 +; +sd_BP dw ? ; caller's BP +sd_args ends +SD_BSIZE equ sd_char-sd_buff ; buffer size + +ENDIF + public str_disp +strdisp proc far +sd_err1: jmp sd_err ; indirect branch to error code + +; load all five (5) of this instruction's operands +str_disp: lods byte ptr ES:[SI] + add AX,offset reg0 + mov BX,AX ; save address of string register + lods word ptr ES:[SI] + mov DX,AX + lods word ptr ES:[SI] + save ; save location pointer + +; allocate local storage + push BP + sub SP,offset sd_BP + mov BP,SP + mov [BP].sd_last,0 ; initialize "last write?" flag + mov [BP].sd_linum,0 ; line number + +; save off argument information + mov [BP].sd_streg,BX + mov [BP].sd_arg45,AX + +; validate the string offsets + xor BX,BX ; clear register BX + mov BL,DL ; copy starting offset register number + add BX,offset reg0 ; and compute register's address + call get_num ; obtain starting offset + jc sd_err1 ; valid offset? if not, error (jump) + add AX,BLK_OVHD ; adjust offset for block header + mov [BP].sd_start,AX ; save starting offset + xor BX,BX + mov BL,DH ; copy ending offset register number + add BX,offset reg0 ; and compute register's address + call get_num ; obtain ending offset + jc sd_err1 ; valid offset? if not, error (jump) + add AX,BLK_OVHD ; adjust offset for block header + cmp AX,[BP].sd_start ; is ending offset greater than starting? + jb sd_err1 ; if ending offset smaller, error (jump) + mov [BP].sd_end,AX ; save ending offset + +; validate the row-bias + xor BX,BX + mov BL,byte ptr [BP].sd_arg45 + cmp byte ptr reg0_pag+[BX],SPECFIX*2 + je next$0 + jmp sd_err +next$0: mov AX,reg0_dis+[BX] + shl AX,1 + sar AX,1 + mov [BP].sd_bias,AX + +; Validate the window operand + xor AX,AX + mov AL,byte ptr [BP].sd_arg45+1 + add AX,offset reg0 + pushm ; push mode=output, reg address + call %getport ; map port operand (result in tmp_reg) + cmp AX,0 ; valid port operand? + jne sd_err ; if not a port, error (jump) + mov SI,tmp_page ; load a pointer to the port object + %LoadPage ES,SI +;;; mov ES,pagetabl+[SI] + mov SI,tmp_disp + mov AX,ES:[SI].pt_pflgs ; load the port attributes + test AX,WINDOW ; is this port a window? + jz sd_err ; if not a window, error (jump) + test AX,OPEN ; window open for output? + jnz sd_open ; if open, jump + jmp sd_done ; if closed, ignore I/O request (jump) +; Move parameters from the window object to local storage +sd_open: mov AX,ES:[SI].pt_cline ; get cursor line number + mov [BP].sd_cline,AX + mov AX,ES:[SI].pt_ccol ; get cursor column number + mov [BP].sd_ccol,AX + mov AX,ES:[SI].pt_nline ; get number of lines in window + mov [BP].sd_nline,AX + mov AX,ES:[SI].pt_ncols ; get number of columns in window + mov [BP].sd_ncols,AX + mov AX,ES:[SI].pt_ullin ; get upper left corner's line number + mov [BP].sd_ullin,AX + mov AX,ES:[SI].pt_ulcol ; get upper left corner's column number + mov [BP].sd_ulcol,AX + mov AX,ES:[SI].pt_text ; get window's text attributes + mov [BP].sd_text,AX + mov [BP].sd_wn_ES,ES ; save pointer to window object + mov [BP].sd_wn_SI,SI + jmp short sd_more ; branch over error code + +; ***error-- invalid operand*** +sd_err: mov SP,BP ; clean up stack + add SP,offset sd_BP + pop BP + restore ; load address of next instruction and + sub SI,6 ; adjust for 5 operands + opcode + mov AX,offset m_st_dsp ; load address of "SUBSTRING-DISPLAY" + pushm ; push arguments to "disassemble" + call %disasse ; create *irritant* (pointer in tmp_reg) + pushm ; push operands + call %set_num ; indicate source operand error + jmp sch_err ; Link to Scheme debugger + +; validate the string operand +sd_more: mov BX,[BP].sd_streg ; load string register's address + mov SI,[BX].C_page ; load string's page number + cmp byte ptr ptype+[SI],STRTYPE*2 ; type = string? + jne sd_err ; if not a string, error (jump) + %LoadPage ES,SI +;;; mov ES,pagetabl+[SI] ; load pointer to string + mov SI,[BX].C_disp + mov AX,ES:[SI].str_len ; load string's length + cmp AX,0 ;;; check length of string + jge sd_010 + add AX,BLK_OVHD+PTRSIZE ;;; adjust for small string +sd_010: cmp AX,[BP].sd_end ; is ending offset too big? + jb sd_err ; if too big, error (jump) +; Note: ES:[SI] points to the source string + mov DX,[BP].sd_end ; load ending displacement and + add DX,SI ; compute ending address + add SI,[BP].sd_start ; compute starting address + +; translate the string into the local buffer + mov CX,[BP].sd_ccol ; load current cursor position + mov BX,[BP].sd_ncols ; load line length + mov DI,BP ; load pointer to local data + add DI,sd_buff ; and address buffer + push DS ; save the data segment register + mov AX,ES ; make DS point to the page containing + mov DS,AX ; the source string +;********************************************************************** +;* * * Warning: The data segment register (DS) does not point to * * * +;* * * the data segment in the code which follows * * * +;********************************************************************** + pop ES ; make ES point to the data segment + push ES + +; Register usage: ES:[DI] - next character in output buffer +; DS:[SI] - next character in source string +; BX - number of columns in window +; CX - current column (cursor position) relative to window +; DX - end of source string address + +sd_next: cmp SI,DX ; end of input string? + jae sd_final ; if end of string, jump + lodsb ; fetch next character from string + cmp AL,CTL_Z ; possible control character? + ja sd_norml ; if not control character, jump + cmp AL,CTL_A ; nul character? + jb sd_next ; if nul character, ignore it (jump) + cmp AL,CTL_I ; tab character? + jne sd_notab ; if not a tab, jump +; TAB character-- output a series of blanks + mov AL," " ; load a blank to store one or more times + mov AH,CL ; copy cursor position + sub AH,[BP].sd_linum ; and adjust for line number +sd_tloop: stosb ; store a blank to the output buffer + inc CX ; increment the current column number + inc AH + test AH,07h ; is next column a multiple of eight? + jnz sd_tloop ; if not, loop + jmp sd_test +; "normal" control character-- prefix with "^" +sd_notab: mov AH,AL ; save control character + mov AL,"^" ; load a "^" character and output to buffer + stosb + inc CX + mov AL,AH ; copy control character to AL and + add AL,"A"-CTL_A ; compute alphabetic for said +; non- control character-- just copy to output buffer +sd_norml: stosb ; store character into output buffer + inc CX ; increment the current column number +sd_test: cmp CX,BX ; line full? + jb sd_next ; if more room on current line, loop + +; Full line buffered-- display it on the screen + call flush ; display line + mov AX,[BP].sd_cline ; load the current line number + cmp AX,[BP].sd_nline ; are we at the end of the screen? + jl sd_next ; if more lines in window, jump +; Window full-- set cursor position to last line + 1, column 0 + les SI,dword ptr [BP].sd_wn_SI ; load pointer to window object + mov ES:[SI].pt_ccol,0 ; set next column number to zero + mov CX,[BP].sd_cline ; store next line number into window + mov ES:[SI].pt_cline,CX ; object, too + jmp sd_fin ; window full, jump + +; end of string-- output final line +sd_final: push ES ; save pointer to data segment + les SI,dword ptr [BP].sd_wn_SI ; load pointer to window object + mov AX,CX ; save current column + mov ES:[SI].pt_ccol,CX ; store next column into window object + mov CX,[BP].sd_cline ; store current line number into window + mov ES:[SI].pt_cline,CX ; object, too + pop ES ; restore pointer to data segment + mov CX,SD_BSIZE-1 ; load buffer length + sub CX,AX ; subtract number of columns in buffer + mov AL," " ; load a blank +rep stosb ; blank the remainder of output buffer + mov [BP].sd_last,1 ; indicate last line + call flush ; display to screen +sd_fin: pop DS ; restore DS + +;********************************************************************** +;* * * Warning: The data segment register (DS) does not point to * * * +;* * * the data segment in the code above * * * +;********************************************************************** + +; Operation complete-- return to Scheme interpreter +sd_done: mov SP,BP ; clean up anything pushed on stack + add SP,offset sd_BP ; deallocate local storage + pop BP ; restore Scheme interpreter's BP + jmp next_PC ; return to Schemem interpreter + +strdisp endp + +;************************************************************************ +;* Local Support: Flush Output Buffer to Screen * +;* * +;* Input Parameters: ES - points to data segment * +;************************************************************************ + public flush +flush proc near + pushm ; save valuable registers +; Make DS register point to data segment + mov AX,ES + mov DS,AX + +; Test for negative bias + inc [BP].sd_bias ; increment and test "bias" value + jg fl_no_bs ; if zero or positive, no bias (jump) + jmp fl_bias ; if negative, don't display current line +; Position the cursor in the current column position +fl_no_bs: mov DL,byte ptr [BP].sd_cline ; load the current cursor + mov DH,byte ptr [BP].sd_ccol ; position + add DL,byte ptr [BP].sd_ullin ; adjust cursor positon by + add DH,byte ptr [BP].sd_ulcol ; coordinates of upper left corner + mov [BP].sd_cursv,DX ; save the cursor coordinates +IFNDEF PROMEM + xor BH,BH ; IBMism (page 0 for text-mode) + mov AH,02h ; load "put cursor" code + call CRT_DSR ; put cursor at current position +ENDIF +; Display the line + mov CX,[BP].sd_ncols ; load line length + sub CX,[BP].sd_ccol ; subtract starting column offset +; Replace the "last" character in line with an exclamation mark + cmp [BP].sd_last,0 ; last line to be output? + jnz fl_last ; if last line, leave character alone (jump) + mov SI,CX ; copy character count + mov AL,"!" ; load an exclamation mark + xchg AL,[BP]+sd_buff+[SI]-1 ; swap with final character in line + mov [BP].sd_char,AL ; save character to later viewing + + public fl_last +fl_last label near +IFDEF PROMEM + buffer_is_stack ;treat comm buffer as stack + mov [BP].sd_len,cx ;save character count + REALIO REAL_WRTBLOCK,sd_len,sd_cursv,continue + buffer_is_buffer ;treat comm buffer as buffer +ELSE +; Determine PC make + cmp PC_MAKE,TIPC ; on what flavor PC are we running? + jne fl_ibm ; if an IBM, jump +; Write line to TIPC's screen + mov AL,byte ptr [BP].sd_text ; load text attributes + mov AH,010h ; load "write block w/ attr" code + mov DX,DS ; load segment address + mov BX,BP + add BX,sd_buff ; load buffer offset in segment + int TI_CRT ; write the buffer + jmp fl_back + +; Write line to IBM's screen +fl_ibm: mov DI,BP + add DI,sd_buff ; load buffer offset + mov DX,[BP].sd_cursv ; reverse row/column coordinates + xchg DL,DH + mov [BP].sd_cursv,DX + push CX ; save the character counter + jmp short fl_imidl ; jump into middle of loop + +fl_iloop: push CX ; save the character counter + mov DX,[BP].sd_cursv ; load the previous cursor coordinates, + inc DL ; increment the column number + mov [BP].sd_cursv,DX ; and save new coordinates + xor BH,BH ; page number (0 for graphics mode) IBMism + mov AH,02h ; load "put cursor" code + push DI + int IBM_CRT + pop DI +fl_imidl: mov AH,09h ; Load "write char w/ attributes" code + mov AL,byte ptr [DI] ; load character from buffer + mov BL,byte ptr [BP].sd_text ; load attribute bits + xor BH,BH ; page # for alpha mode + mov CX,1 ; load repeat count = 1 +; test to see if we buy anything by using a repeat count + pop DX ; restore character count +fl_imore: cmp DX,1 ; more characters to display? + jle fl_ibotm ; if no more characters, jump + cmp AL,byte ptr [DI]+1 ; is next character the same as previous? + jne fl_ibotm ; if not same character, jump + inc CX ; increment the repeat count + inc DI ; increment the output buffer index + inc byte ptr [BP].sd_cursv ; increment the cursor position + dec DX ; decrement the character count + jmp fl_imore ; try for another +fl_ibotm: push DX ; save the adjusted character count +; output the character(s) + push DI ; save the output buffer index + int IBM_CRT ; write character with attributes + pop DI ; restore the output buffer index + pop CX ; restore character counter + inc DI ; increment buffer pointer + loop fl_iloop ; continue 'til all characters output +ENDIF + +; Restore last character in line to its rightful value +fl_back: mov SI,[BP].sd_ncols + sub SI,[BP].sd_ccol + mov AL,[BP].sd_char + mov [BP]+sd_buff+[SI]-1,AL + +; Shift buffer to remove the line just displayed + inc [BP].sd_cline ; increment the line number +fl_bias: mov SI,[BP].sd_ncols ; compute number of characters just output + sub SI,[BP].sd_ccol ; (unless bias < 0, in which case we just + dec SI ; branched here) + push SI ; save character count + mov CX,10 ; make up a character count for move + mov DI,BP ; load address of buffer start + add DI,sd_buff + add SI,BP ; load address of leftover characters + add si,sd_buff +rep movsb ; shift any characters left over + mov BX,[BP].sd_ccol ;;; new code for fix + ;;; save the current column for adjust + mov [BP].sd_ccol,0 ; set current column to zero + inc [BP].sd_linum ; increment formatting line number + +; Reset Active Registers to reflect shifted buffer + pop AX ; restore output character count + popm ; restore control registers + sub DI,AX ; adjust buffer index + sub CX,AX ; adjust current column + sub CX,BX ;;; new code for fix + ;;; adjust current column + mov BX,[BP].sd_ncols ; reload line length + pop DS ; restore DS register + ret ; return +flush endp + +;************************************************************************ +;* Local Support: Fetch and Validate Integer Argument * +;* * +;* Input Parameters: BX - address of register containing the integer * +;* argument * +;* * +;* Output Parameters: If CARRY off, normal return: * +;* AX - the 16 bit positive integer value * +;* If CARRY on, error: * +;* AX - the error condition; 0=operand not an * +;* integer; 1=integer operand was negative * +;* or larger than 16 bits. * +;************************************************************************ + public get_num +get_num proc near +; test for a fixnum argument + cmp byte ptr [BX].C_page,SPECFIX*2 ; fixnum? + jne big_p ; if not a fixnum, test for bignum (jump) + mov AX,[BX].C_disp ; load immediate value of fixnum + test AX,04000h ; negative? + jnz get_val ; if negative, error (jump) + ret ; if positive, return with value in AX + +; test for a bignum argument +big_p: mov SI,[BX].C_page ; load page number of argument + cmp byte ptr ptype+[SI],BIGTYPE*2 ; is argument a bignum? + jne get_type ; if not a bignum, invalid type (jump) + %LoadPage ES,SI +;;; mov ES,pagetabl+[SI] ; load paragraph address of bignum's page + mov SI,[BX].C_disp ; load displacement of bignum + cmp ES:[SI].big_sign,0 ; test sign of bignum + jne get_val ; if negative, error (jump) + cmp ES:[SI].big_len,BLK_OVHD+WORDINCR+1 ; test size of bignum + jne get_val ; if too large, error (jump) + mov AX,ES:[SI].big_data ; load 16 bit value of bignum + clc + ret ; return with value in AX +; ***error-- operand is not an integer*** +get_type: mov AX,0 ; indicate operand wrong type + jmp short get_err +; ***error-- integer operand is negative, or too large*** +get_val: mov AX,1 +get_err: stc + ret +get_num endp + +;************************************************************************ +;* Local Support: Return a 16 bit positive integer value * +;* * +;* Input Parameters: BX - address of destination register * +;* SI - 16 bit unsigned integer value to be returned * +;* * +;* Output Parameters: The Scheme representation of the 16 bit unsigned * +;* value is placed into the destination register. * +;************************************************************************ + public ret_num +ret_num proc near + cmp SI,03fffh ; can result be represented as a fixnum? + ja make_big ; if not, create a bignum +; return a fixnum result + mov byte ptr [BX].C_page,SPECFIX*2 ; set tag=fixnum + mov [BX].C_disp,SI ; store value + ret ; return +; return a bignum result +make_big: + push SI ; save value around call + push BX ; save destination reg also + + mov CX,WORDINCR+1 ; load size of bignum desired + mov AX,BIGTYPE ; load type = bignum + pushm ; push arguments to allocate block + call %allocbl ; allocate the bignum + add SP,WORDINCR*3 ; drop arguments off stack + + pop BX ; restore destination reg + mov SI,[BX].C_page ; get page number of new bignum + %LoadPage ES,SI ; and fetch its segment address + mov SI,[BX].C_disp ; load the bignum's displacement + mov ES:[SI].big_sign,0 ; set bignum's sign to '+' + pop AX ; restore value and + mov ES:[SI].big_data,AX ; store it into the bignum + ret ; return +ret_num endp + + +PROGX ends + +prog segment byte public 'PROG' + assume CS:PGROUP +;************************************************************************ +;* Long Linkage to SUBSTRING-FIND-NEXT-CHAR-IN-SET * +;************************************************************************ + public srch_nxt +srch_nxt proc near + call %srchnxt + ret +srch_nxt endp + +;************************************************************************ +;* Long Linkage to SUBSTRING-FIND-PREVIOUS-CHAR-IN-SET * +;************************************************************************ + public srch_prv +srch_prv proc near + call %srchprv + ret +srch_prv endp + +;************************************************************************ +;* Long Linkage to STRING-LENGTH * +;************************************************************************ + public st_len +st_len proc near + call %st_len + ret +st_len endp + +;************************************************************************ +;* Long Linkage to MAKE-STRING * +;************************************************************************ +;;; public make_str +make_str proc near + call %makestr + ret +make_str endp + +;************************************************************************ +;* Long Linkage to REIFY_STACK * +;************************************************************************ + public reif_stk +reif_stk proc near + call %reifstk + ret +reif_stk endp + +;************************************************************************ +;* Long Linkage to REIFY_STACK! * +;************************************************************************ + public reif_stb +reif_stb proc near + call %reifstb + ret +reif_stb endp + +prog ends + end + \ No newline at end of file diff --git a/srelocat.asm b/srelocat.asm new file mode 100644 index 0000000..348c671 --- /dev/null +++ b/srelocat.asm @@ -0,0 +1,490 @@ +; =====> SRELOCAT.ASM +;*************************************** +;* TIPC Scheme Runtime Support * +;* GC Pointer Relocation Routines * +;* * +;* (C) Copyright 1985 by Texas * +;* Instruments Incorporated. * +;* All rights reserved. * +;* * +;* Date Written: 23 September 1985 * +;* Last Modification: 18 October 1985 * +;*************************************** + include scheme.equ + +DGROUP group data +XGROUP group PROGX +PGROUP group prog + +data segment word public 'DATA' + assume DS:DGROUP + +msg_relp db "[VM INTERNAL ERROR] rel_ptr: invalid %x:%04x (unadjusted)" + db LF,0 + +page_sav dw ? ; Page number save area + +; Branch table for processing each data type +btable dw rel_list ; [0] List cells + dw rel_fix ; [1] Fixnums + dw rel_flo ; [2] Flonums + dw rel_big ; [3] Bignums + dw rel_sym ; [4] Symbols + dw rel_str ; [5] Strings + dw rel_ary ; [6] Arrays + dw rel_cont ; [7] Continuations + dw rel_clos ; [8] Closures + dw rel_free ; [9] Free space (unallocated) + dw rel_code ; [10] Code + dw rel_ref ; [11] Reference cells + dw rel_port ; [12] Port data objects + dw rel_char ; [13] Characters + dw rel_env ; [14] Environments + +ctable dw rep_list ; [0] List cells + dw rep_fix ; [1] Fixnums + dw rep_flo ; [2] Flonums + dw rep_big ; [3] Bignums + dw rep_sym ; [4] Symbols + dw rep_str ; [5] Strings + dw rep_ary ; [6] Arrays + dw rep_cont ; [7] Continuations + dw rep_clos ; [8] Closures + dw rep_free ; [9] Free space (unallocated) + dw rep_code ; [10] Code + dw rep_ref ; [11] Reference cells + dw rep_port ; [12] Port data objects + dw rep_char ; [13] Characters + dw rep_env ; [14] Environments + +dtable dw fwd_list ; [0] List cells + dw fwd_fix ; [1] Fixnums + dw fwd_flo ; [2] Flonums + dw fwd_big ; [3] Bignums + dw fwd_sym ; [4] Symbols + dw fwd_str ; [5] Strings + dw fwd_ary ; [6] Arrays + dw fwd_cont ; [7] Continuations + dw fwd_clos ; [8] Closures + dw fwd_free ; [9] Free space (unallocated) + dw fwd_code ; [10] Code + dw fwd_ref ; [11] Reference cells + dw fwd_port ; [12] Port data objects + dw fwd_char ; [13] Characters + dw fwd_env ; [14] Environments +data ends + +prog segment byte public 'PROG' + assume CS:PGROUP + extrn %printf:far + +;************************************************************************ +;* Far Linkage to FORCE_DEBUG * +;************************************************************************ +%forcede proc far + extrn force_de:near + call force_de + ret +%forcede endp + +prog ends + +PROGX segment byte public 'PROGX' + assume CS:XGROUP + +;************************************************************************ +;* Garbage Collection -- Pointer Relocation Phase * +;************************************************************************ + public srelocat +srelocat proc near + push ES ; save caller's ES register + push BP ; and BP register + mov BP,SP ; and establish addressability + +; relocate the pointers within each page + mov BX,DEDPAGES*WORDINCR ; initialize page counter +srel_lop: test attrib+[BX],NOMEMORY + jnz srel_nxt + mov DI,SS:ptype+[BX] ; get data type for page + cmp DI,FREETYPE*2 ; Free Page? + je srel_nxt ; Yes...continue + push BX ; save the page counter + call rel_page ; relocate pointers in current page + pop BX ; restore page counter +srel_nxt: add BX,WORDINCR ; increment page counter + cmp BX,NUMPAGES*WORDINCR ; all pages processed? + jb srel_lop ; if more pages, jump + +; relocate registers R1-R63 + xor BX,BX ; clear BX + mov CX,NUM_REGS-1 ; load number of registers ('cept for R0) + mov DI,offset reg0 + size C_ptr ; load address of R1 +srel_reg: call rel_reg ; relocate register Rn + add DI,size C_ptr ; increment pointer to next reigster + loop srel_reg ; loop until R1-R63 relocated + +; relocate the other internal registers + mov DI,offset FNV_reg + call rel_reg ; relocate FNV_reg + mov DI,offset GNV_reg + call rel_reg ; relocate GNV_reg + mov DI,offset PREV_reg + call rel_reg ; relocate PREV_reg + mov DI,offset CB_reg + call rel_reg ; relocate CB_reg + mov DI,offset TRNS_reg + call rel_reg ; relocate TRNS_reg + mov DI,offset tmp_reg + call rel_reg ; relocate tmp_reg + mov DI,offset tm2_reg + call rel_reg ; relocate tm2_reg + mov DI,offset FNV_save + call rel_reg ; relocate FNV_save + mov DI,offset STL_save + call rel_reg ; relocate STL_save + +; relocate the system oblist and the property lists + mov CX,HT_SIZE ; load iteration count + xor DX,DX ; zero the index +rel_tab: mov DI,DX ; copy loop index to DI + mov BL,hash_pag+[DI] ; fetch hash table entry page number + shl DI,1 ; double index value for use as word index + mov SI,hash_dis+[DI] ; fetch hash table entry displacement + call rel_ptr ; relocate the pointer + mov hash_dis+[DI],SI ; store the relocated + mov SI,DX ; pointer back into the + mov hash_pag+[SI],BL ; system hash table + mov BL,prop_pag+[SI] ; fetch property list entry page number + mov SI,prop_dis+[DI] ; and displacement + call rel_ptr ; relocate the property list entry pointer + mov prop_dis+[DI],SI ; store the relocated + mov DI,DX ; pointer back into the + mov prop_pag+[DI],BL ; system property list table + inc DX ; increment the loop index + loop rel_tab ; continue 'til all entries processed + +; Relocate the pointers in the runtime stack + mov DI,offset S_stack ; load address of stack buffer + mov DX,TOS ; load current top of stack and + add DX,DI ; compute stack's ending address +rel_stk: mov BL,[DI].car_page ; load next stack entry from the + mov SI,[DI].car ; stack buffer + call rel_ptr ; relocate the pointer + mov [DI].car_page,BL ; store the relocated pointer back into + mov [DI].car,SI ; the stack buffer + add DI,PTRSIZE ; increment the stack buffer pointer + cmp DI,DX ; end of active stack buffer? + jbe rel_stk ; if more entries in stack, jump + +; Relocate the pointers in the object hash table + mov CX,OHT_SIZE ; load count of object hash table entries + mov DI,offset obj_ht ; load address of object hash table +rel_oht: mov BL,[DI].car_page ; load next entry in the + mov SI,[DI].car ; object hash table + call rel_ptr ; relocate the pointer + mov [DI].car_page,BL ; store the relocated pointer back + mov [DI].car,SI ; into the object hash table + add DI,PTRSIZE ; increment the loop index + loop rel_oht ; continue until all entries processed + +; Return to caller +rel_rtn: pop BP ; restore caller's BP register + pop ES ; and ES register + ret ; return +srelocat endp + +;************************************************************************ +;* Local Support-- Relocate pointers in a single page * +;************************************************************************ +rel_page proc near + mov page_sav,BX ; Save this page number + %LoadPage ES,BX ; load the page's paragraph address +;;; mov ES,pagetabl+[BX] ; load the page's paragraph address + mov DX,psize+[BX] ; load the current page size + sub DX,PTRSIZE ; and adjust for end of page boundary + mov SI,ptype+[BX] + xor DI,DI ; zero the page index + xor BX,BX ; zero BX + jmp btable+[SI] + +rel_list: ; [0] List cells + sub DX,LISTSIZE-PTRSIZE +rel_l010: mov BL,ES:[DI].car_page ; fetch the car field's page number + cmp BL,0FFh ; unused list cell? + je rel_l020 ; if unused, jump + test byte ptr ES:[DI].list_gc,GC_BIT ; is this a relocated pointer? + jnz rel_l020 ; if a relocated ptr, leave it alone + mov SI,ES:[DI].car ; fetch the car field's displacement field + call rel_ptr ; relocate the pointer + %LoadPage ES,page_sav ; Re-load source page + mov ES:[DI].car_page,BL ; store the relocated car pointer + mov ES:[DI].car,SI ; back into the list cell + mov BL,ES:[DI].cdr_page ; fetch the cdr field from + mov SI,ES:[DI].cdr ; the list cell + call rel_ptr ; relocate the pointer + %LoadPage ES,page_sav ; Re-load source page + mov ES:[DI].cdr_page,BL ; store the relocated cdr pointer + mov ES:[DI].cdr,SI ; back into the list cell +rel_l020: add DI,LISTSIZE ; increment the page index + cmp DI,DX ; end of page? + jbe rel_l010 ; if more list cells to process, jump + jmp rel_ret ; return + +rel_sym: ; [4] Symbols +rel_port: ; [12] Port data objects +rel_s010: cmp ES:[DI].sym_type,FREETYPE ; free block? + je rel_s020 ; if free block, jump + test ES:[DI].sym_gc,GC_BIT ; is this a relocated object? + jnz rel_s020 ; if a forwarding pointer, jump + mov BL,ES:[DI].sym_page ; load pointer operand from the + mov SI,ES:[DI].sym_disp ; port or symbol object + call rel_ptr ; relocate the pointer, if needed + %LoadPage ES,page_sav ; Re-load source page + mov ES:[DI].sym_page,BL ; store relocated pointer back in + mov ES:[DI].sym_disp,SI ; the port or symbol +rel_s020: add DI,ES:[DI].sym_len ; increment the page index + cmp DI,DX ; end of page? + jbe rel_s010 ; if not end of page, jump + jmp rel_ret ; return + + +rel_code: ; [10] Code +rel_c010: cmp ES:[DI].cod_type,FREETYPE ; is this a free block? + je rel_c030 ; if unused block, jump + test ES:[DI].cod_gc,GC_BIT ; is this a relocated code block? + jnz rel_c030 ; if a forwarding pointer, jump + mov AX,DI ; save starting offset of object + mov CX,ES:[DI].cod_entr ; load the entry point + add CX,DI ; and compute ending offset + sub CX,BLK_OVHD+PTRSIZE + jmp short rel_c025 ; test for code block with no constants +rel_c020: mov BL,ES:[DI].cod_cpag ; load next pointer from the + mov SI,ES:[DI].cod_cdis ; object + call rel_ptr ; relocate pointer, if needed + %LoadPage ES,page_sav ; Re-load source page + mov ES:[DI].cod_cpag,BL ; store the relocated pointer + mov ES:[DI].cod_cdis,SI ; back into the object + add DI,PTRSIZE ; increment the page index +rel_c025: cmp DI,CX ; all pointers updated? + jb rel_c020 ; if more pointers, jump + mov DI,AX ; restore starting offset of object +rel_c030: add DI,ES:[DI].cod_len ; adjust index for free area + cmp DI,DX ; end of page? + jbe rel_c010 ; if not end of page, jump + jmp rel_ret ; return + +rel_ary: ; [6] Arrays +rel_cont: ; [7] Continuations +rel_clos: ; [8] Closures +rel_env: ; [14] Environments +rel_v010: cmp ES:[DI].vec_type,FREETYPE ; is this a free block? + je rel_v030 ; if unused block, jump + test ES:[DI].vec_gc,GC_BIT ; has object been relocated? + jnz rel_v030 ; if a forwarding pointer, jump + mov AX,DI ; save starting offset of object + mov CX,ES:[DI].vec_len ; load the object's length + add CX,DI ; and compute ending offset + sub CX,BLK_OVHD ; adjust ending offset for block header + jmp short rel_v025 ; test for zero length object +rel_v020: mov BL,ES:[DI].vec_page ; load next pointer from the + mov SI,ES:[DI].vec_disp ; object + call rel_ptr ; relocate pointer, if needed + %LoadPage ES,page_sav ; Re-load source page + mov ES:[DI].vec_page,BL ; store the relocated pointer + mov ES:[DI].vec_disp,SI ; back into the object + add DI,PTRSIZE ; increment the page index +rel_v025: cmp DI,CX ; all pointers updated? + jb rel_v020 ; if more pointers, jump + mov DI,AX ; restore starting offset of object +rel_v030: add DI,ES:[DI].vec_len ; adjust index for free area + cmp DI,DX ; end of page? + jbe rel_v010 ; if not end of page, jump + jmp rel_ret ; return + +rel_fix: ; [1] Fixnums +rel_flo: ; [2] Flonums +rel_big: ; [3] Bignums +rel_str: ; [5] Strings +rel_free: ; [9] Free space (unallocated) +rel_ref: ; [11] Reference cells (hope not...) +rel_char: ; [13] Characters + +rel_ret: ret ; return to caller +rel_page endp + +;************************************************************************ +;* Local Support-- Relocate a pointer contained in a register * +;* * +;* Parameters: DI - address of register * +;************************************************************************ +rel_reg proc near + xor BX,BX ; clear BX + mov BL,byte ptr [DI].C_page ; fetch the register's + mov SI,[DI].C_disp ; contents + call rel_ptr ; relocate the pointer + mov byte ptr [DI].C_page,BL ; store the relocated pointer + mov [DI].C_disp,SI ; back into the register + ret ; return +rel_reg endp + +;************************************************************************ +;* Local Support-- Relocate a single pointer * +;* * +;* Parameters: BX - page number index (page*2) * +;* SI - displacement * +;************************************************************************ +rel_ptr proc near + cmp BX,DEDPAGES*WORDINCR ; is this a special non-GCed page? + jl rep_ret1 ; if special page, no relocation done + push ES ; save caller's ES + push DI ; and save caller's DI + %LoadPage ES,BX ; load the paragraph address for ptr's page +;;; mov ES,pagetabl+[BX] ; load paragraph address for pointer's page + mov DI,ptype+[BX] + cmp DI,NUMTYPES*2 + jae rel_oops + jmp ctable+[DI] ; jump according to pointer type + +; ***error-- invalid type/length code*** +rel_oops: pushm ; save registers; push page:disp + mov AX,offset msg_relp ; move address of "format" + push AX ; and push as argument to printf + mov AX,DS ; make ES point to the data segment + mov ES,AX + call %printf ; print the error message + call %forcede ; invoke the VM debugger with next instr. + popm ; restore registers + jmp short rep_ret ; return + +rep_list: ; [0] List Cells + test byte ptr ES:[SI].list_gc,GC_BIT ; has cell been relocated? + jz rep_ret ; if not moved, return (jump) + mov BL,ES:[SI].car_page ; replace original pointer with + mov SI,ES:[SI].car ; the updated pointer + and SI,07FFFh ; clear the GC bit + jmp short rep_ret ; return + +rep_flo: ; [2] Flonums + test byte ptr ES:[SI].flo_gc,GC_bit ; has flonum been relocated? + jz rep_ret ; if not moved, return (jump) + mov BL,ES:[SI].flo_data ; replace original pointer with + mov SI,word ptr ES:[SI].flo_data+1 ; the updated pointer + jmp short rep_ret ; return + +rep_big: ; [3] Bignums +rep_sym: ; [4] Symbols +rep_str: ; [5] Strings +rep_ary: ; [6] Arrays +rep_cont: ; [7] Continuations +rep_clos: ; [8] Closures +rep_code: ; [10] Code +rep_port: ; [12] Port data objects +rep_env: ; [14] Environments + test byte ptr ES:[SI].vec_gc,GC_bit ; has object been relocated? + jz rep_ret ; if not moved, return (jump) + mov BL,ES:[SI].vec_page ; replace original pointer with + mov SI,ES:[SI].vec_disp ; the updated pointer + jmp rep_ret ; return + +rep_fix: ; [1] Fixnums +rep_free: ; [9] Free space (unallocated) +rep_ref: ; [11] Reference cells (hope not...) +rep_char: ; [13] Characters + +rep_ret: pop DI ; restore caller's DI + pop ES ; restore caller's ES +rep_ret1: ret ; return to caller +rel_ptr endp + +;************************************************************************ +;* Complement GC (forwarding) Bits * +;************************************************************************ + public toggleGC +toggleGC proc near + push ES ; save caller's ES register + push BP ; and BP register + mov BP,SP ; and establish addressability + mov BX,DEDPAGES*WORDINCR ; initialize page counter +togl_lop: test attrib+[BX],NOMEMORY + jnz togl_nxt + mov DI,SS:ptype+[BX] ; get data type for page + cmp DI,FREETYPE*2 ; Free Page? + je togl_nxt ; Yes...continue + push BX ; save the page counter + call togl_pag ; complement GC bits in current page + pop BX ; restore page counter +togl_nxt: add BX,WORDINCR ; increment page counter + cmp BX,NUMPAGES*WORDINCR ; all pages processed? + jb togl_lop ; if more pages, jump + mov SP,BP + pop BP + pop ES + ret +toggleGC endp + + +togl_pag proc near + %LoadPage ES,BX ; load the page's paragraph address +;;; mov ES,pagetabl+[BX] ; load the page's paragraph address + mov DX,psize+[BX] ; load the current page size + sub DX,PTRSIZE ; and adjust for end of page boundary + mov SI,ptype+[BX] + xor DI,DI ; zero the page index + xor BX,BX ; zero BX + jmp dtable+[SI] + +fwd_list: ; [0] List cells + sub DX,LISTSIZE-PTRSIZE +fwd_l010: cmp ES:[DI].car_page,0FFh ; unused list cell? + je fwd_l020 ; if unused, jump + xor byte ptr ES:[DI].list_gc,GC_BIT ; toggle the GC (forward) bit +fwd_l020: add DI,LISTSIZE ; increment the page index + cmp DI,DX ; end of page? + jbe fwd_l010 ; if more list cells to process, jump + jmp togl_ret ; return + + +fwd_flo: ; [2] Flonums + sub DX,FLOSIZE-PTRSIZE +fwd_f010: cmp byte ptr ES:[DI].flo_type,0FFh ; unused flonum? + je fwd_f020 ; if unused, jump + xor byte ptr ES:[DI].flo_gc,GC_BIT ; toggle the GC (forward) bit +fwd_f020: add DI,FLOSIZE ; increment the page index + cmp DI,DX ; end of page? + jbe fwd_f010 ; if more flonums to process, jump + jmp togl_ret ; return + + +fwd_str: ; [5] Strings + +fwd_big: ; [3] Bignums +fwd_sym: ; [4] Symbols +fwd_ary: ; [6] Arrays +fwd_cont: ; [7] Continuations +fwd_clos: ; [8] Closures +fwd_code: ; [10] Code +fwd_port: ; [12] Port data objects +fwd_env: ; [14] Environments +fwd_v010: cmp ES:[DI].vec_type,FREETYPE ; is this a free block? + je fwd_v030 ; if unused block, jump + xor ES:[DI].vec_gc,GC_BIT ; toggle GC (forward) bit +fwd_v030: mov CX,ES:[DI].vec_len ; adjust index for free area + cmp CX,0 ;;; check for small string + jge fwd_v040 + mov CX,BLK_OVHD+PTRSIZE +fwd_v040: add DI,CX + cmp DI,DX ; end of page? + jbe fwd_v010 ; if not end of page, jump + jmp togl_ret ; return + +fwd_fix: ; [1] Fixnums +fwd_free: ; [9] Free space (unallocated) +fwd_ref: ; [11] Reference cells +fwd_char: ; [13] Characters + +togl_ret: ret ; return to caller +togl_pag endp + +PROGX ends + end + \ No newline at end of file diff --git a/sstack.asm b/sstack.asm new file mode 100644 index 0000000..358bc7e --- /dev/null +++ b/sstack.asm @@ -0,0 +1,1807 @@ +; =====> SSTACK.ASM +;*************************************** +;* TIPC Scheme '84 Runtime Support * +;* Interpreter -- Stack Operations * +;* * +;* (C) Copyright 1984,1985 by Texas * +;* Instruments Incorporated. * +;* All rights reserved. * +;* * +;* Date Written: 2 May 1984 * +;* Last Modification: 22 October 1985 * +;*************************************** +;* Modification History: +;* 06 Mar 86 - Recoded the C_push and C_pop routines to attemp to +;* (JCJ) improve their performance and memory utilization. +;* + include scheme.equ + include sinterp.mac + + include sinterp.arg + include stackf.equ ; define stack frame format + +XGROUP group PROGX +DGROUP group data +data segment word public 'DATA' + assume DS:DGROUP + public stk_in,stk_out +stk_in dd 0 ; number of bytes moved into the stack +stk_out dd 0 ; number of bytes moved out of the stack +m_%exec db "%EXECUTE",0 +m_stk_un db "[VM INTERNAL ERROR] Stack underflow",LF,0 +m_stk_ov db LF,"[VM ERROR encountered!] Recursion too deep: Stack " + db "overflow",LF,0 +clos_ptr dw 0 ; register number containing closure pointer + +m_APPLY dw APPLY_ARG_LIMIT_ERROR +m_AP1 db "APPLY",0 ; text for "apply" function name +m_AP_adr dw m_AP1 ; address of above text +m_one dw 1 ; a constant "one" (1) + + +data ends + +PGROUP group prog +prog segment byte public 'PROG' + assume CS:PGROUP + +stk_int 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 ; All of the above, with "mov SP,BP" first + extrn src_err:near ; "source operand error" message display + extrn sch_err:near ; Link to Scheme Debugger + extrn printf_c:near ; Error message print routine + + extrn %allocbl:far ; Far linkage to "alloc_block" + +;************************************************************************ +;* AL * +;* Push register onto stack PUSH reg * +;* * +;* Purpose: Interpreter support to cause the contents of one of the * +;* VM's general registers to be pushed onto the VM's * +;* runtime stack * +;************************************************************************ + public spush +spush: lods byte ptr ES:[SI] ; load number of register to push +spush1: mov DI,TOS ; load top of stack pointer + cmp DI,STKSIZE-PTRSIZE ; test for overflow + jge spush2 ; jump if overflow will occur + add DI,PTRSIZE ; decrement stack top pointer + mov TOS,DI ; update TOS pointer in memory + mov BX,AX ; copy register number + mov AL,byte ptr reg0_pag+[BX] ; load page number from register + mov S_stack+[DI].car_page,AL ; and move to the stack + mov AX,reg0_dis+[BX] ; same for displacement + mov word ptr S_stack+[DI].car,AX + jmp next +; process stack overflow-- copy contents to heap +spush2: pushm ; preserve "important" regs across call + call stk_ovfl ; handle overflow situation + popm ; restore "important" registers + jmp spush1 ; re-try push + + +;************************************************************************ +;* AL * +;* Pop register from stack POP reg * +;* * +;* Purpose: Interpreter support to cause the contents of one of the * +;* VM's general registers to be replaced by popping the * +;* value off the top of the VM's runtime stack * +;* * +;* Note: There's no need to check for stack underflow on a simple * +;* POP, because the stack is broken into segments only at stack * +;* frame boundaries. Underflow can occur only when stack space * +;* for a stack frame is released (i.e., during an EXIT). * +;************************************************************************ + public spop +spop: lods byte ptr ES:[SI] ; load number of register to pop + mov DI,TOS ; load top of stack pointer + mov BX,AX ; copy register number + mov AL,S_stack+[DI].car_page ; move page no. from stack + mov byte ptr reg0_pag+[BX],AL ; and update in register + mov AX,word ptr S_stack+[DI].car ; same for displacement + mov reg0_dis+[BX],AX + sub DI,PTRSIZE ; decrement TOS pointer + mov TOS,DI ; update TOS pointer in memory + jmp next + + +;************************************************************************ +;* AL * +;* Drop-- remove top elements from stack DROP n * +;* * +;* Purpose: Interpreter support to cause the top "n" elements of the * +;* VM's runtime stack to be discarded. "n" is determined * +;* from the operand of the DROP instruction * +;* * +;* Note: There's no need to check for stack underflow on a DROP * +;* because the stack is broken into segments only at stack * +;* frame boundaries. Underflow can occur only when stack space * +;* for a stack frame is released (i.e., during an EXIT). * +;************************************************************************ + public sdrop +sdrop: lods byte ptr ES:[SI] ; load number of elements to drop + mov DX,AX ; multiply by 3 (size of element) + shl AX,1 + add AX,DX + sub TOS,AX ; update TOS pointer in memory + jmp next ; return to interpreter + + +;************************************************************************ +;* AL AH * +;* Local from local stack frame LDLOCAL dest,entry * +;************************************************************************ + public ld_local +ld_local: lods word ptr ES:[SI] ; load dest reg, entry number operands + mov BL,AL ; copy destination register number + mov DI,BX ; into DI (clear high order byte) + mov BL,AH ; copy the entry number (clear high byte) + mov AX,BX ; BX <- entry * 3 + sal AX,1 + add BX,AX + add BX,FP ; BX <- FP + (entry * 3) + mov AL,S_stack+[BX].sf_dat_p ; move page number of entry to + mov byte ptr reg0_pag+[DI],AL ; destination register + mov AX,word ptr S_stack+[BX].sf_dat_d ; move displacement of + mov reg0_dis+[DI],AX ; entry to destination register + jmp next + +;************************************************************************ +;* AL AH * +;* Store into local stack frame STLOCAL src,entry * +;************************************************************************ + public st_local +st_local: lods word ptr ES:[SI] ; load dest reg, entry number operands + mov BL,AL ; copy destination register number + mov DI,BX ; into DI (clear high order byte) + mov BL,AH ; copy the entry number (clear high byte) + mov AX,BX ; BX <- entry * 3 + sal AX,1 + add BX,AX + add BX,FP ; BX <- FP + (entry * 3) +; cmp BX,TOS ; store out of range? +; jgt st_err ; if so, record error + mov AL,byte ptr reg0_pag+[DI] ; move page number of entry from + mov S_stack+[BX].sf_dat_p,AL ; destination register + mov AX,reg0_dis+[DI] ; move displacement of entry from + mov word ptr S_stack+[BX].sf_dat_d,AX ; destination register + jmp next + + +;************************************************************************ +;* AL AL AH * +;* Load from higher lexical level LDLEX dest,entry,lvl * +;************************************************************************ + public ld_lex +ld_lex: lods byte ptr ES:[SI] ; load destination register operand + push AX ; and save it + lods word ptr ES:[SI] ; load lexical level and entry number + save ; save current location pointer + mov BL,AH ; clear high order byte of the lexical + mov CX,BX ; level number delta and move to CX + mov BL,AL ; align, and save entry number + push BX + call delta_lv ; get pointer to parent's stack frame + pop AX ; get entry number + mov BX,AX ; BX <- entry number * 3 + shl AX,1 + add BX,AX + pop DI ; get destination register number + mov AL,ES:[SI].sf_dat_p+[BX] ; copy lexical entry from stack + mov byte ptr reg0_pag+[DI],AL ; frame to destination register + mov AX,ES:[SI].sf_dat_d+[BX] + mov reg0_dis+[DI],AX + jmp next_PC ; return to the interpreter + + +;************************************************************************ +;* AL AL AH * +;* Store into higher lexical level STLEX src,entry,lvl * +;************************************************************************ + public st_lex +st_lex: lods byte ptr ES:[SI] ; load source register operand + push AX ; and save it + lods word ptr ES:[SI] ; load lexical level and entry number + save ; save current location pointer + mov BL,AH ; clear high order byte of the lexical + mov CX,BX ; level number delta and move to CX + mov BL,AL ; align, and save entry number + push BX + call delta_lv ; get pointer to parent's stack frame + pop AX ; get entry number + mov BX,AX ; BX <- entry number * 3 + shl AX,1 + add BX,AX + pop DI ; get source register number + mov AL,byte ptr reg0_pag+[DI] ; copy contents of register into + mov ES:[SI].sf_dat_p+[BX],AL ; lexical entry of stack + mov AX,reg0_dis+[DI] + mov ES:[SI].sf_dat_d+[BX],AX + jmp next_PC ; return to the interpreter + + +;************************************************************************ +;* AX AL AH * +;* Call local routine CALL lbl,delta-lvl,delta-heap* +;************************************************************************ + public call_lcl +call_lcl: mov AX,offset PGROUP:next_PC ; For a "CALL", make a tail + push AX ; recursive call to following routine + +cl_l_sub: lods word ptr ES:[SI] ; load branch displacement + mov DX,AX ; and save in register DX + + lods word ptr ES:[SI] ; load delta-level,delta-heap numbers + inc AL ; increment releative lexical level + mov BL,AL ; isolate delta-lvl and save it + push BX + mov BL,AH ; isolate delta-heap and save it, too + push BX + + add DX,SI ; compute branch destination address + mov [BP].save_SI,DX ; store updated location counter + + call new_SF ; allocate new stack frame on top of stack + mov SI,BX ; save pointer to new stack frame + + pop CX ; restore the delta-heap argument + call delta_hp ; determine new heap env pointer + mov S_stack+[SI].sf_hpage,BL ; store new heap env pointer into + mov word ptr S_stack+[SI].sf_hdisp,DI ; new stack frame + + pop CX ; restore the delta-lvl argument + push SI ; save new stack frame pointer + call delta_lv ; get static link + pop SI ; retrieve new stack frame pointer + mov word ptr S_stack+[SI].sf_sdisp,BX ; update static link + + mov FP,SI ; update current frame pointer + ret ; return to interpreter, or call/cc support + + +;************************************************************************ +;* AX AL AH * +;* Call local routine tail recursively CALL-TR lbl,delta-lvl,delta-heap* +;************************************************************************ + public call_ltr +call_ltr: mov AX,offset PGROUP:next_PC ; For a "CALL-TR", make a tail + push AX ; recursive call to following routine + +cl_lt_sb: lods word ptr ES:[SI] ; load branch displacement + mov DX,AX ; and save in register DX + + lods word ptr ES:[SI] ; load delta-level,delta-heap numbers + inc AL ; increment releative lexical level + mov BL,AL ; isolate delta-lvl and save it + push BX + mov BL,AH ; isolate delta-heap and save it, too + mov CX,BX + + add DX,SI ; compute branch destination address + mov [BP].save_SI,DX ; store updated location counter + + mov AX,FP ; load pointer to current stack frame + mov SI,AX + add AX,SF_OVHD-PTRSIZE + mov TOS,AX ; drop any local var's off top of stack + + call delta_hp ; determine new heap env pointer + mov S_stack+[SI].sf_hpage,BL ; store new heap env pointer into + mov word ptr S_stack+[SI].sf_hdisp,DI ; new stack frame + + mov S_stack+[SI].sf_cl_pg,NIL_PAGE*2 ; nil out closure pointer + mov word ptr S_stack+[SI].sf_cl_ds,NIL_DISP ; entry in stack frame + + pop CX ; restore the delta-lvl argument + push SI ; save pointer to stack frame + call delta_lv ; get static link + pop SI ; retrieve pointer to stack frame + mov word ptr S_stack+[SI].sf_sdisp,BX ; update static link + + ret ; return to interpreter, or call/cc support + + +;************************************************************************ +;* AL AH * +;* Call closed procedure CALL-CLOSURE ftn,#args * +;* * +;* Purpose: Scheme interpreter support for procedure calls to fully * +;* closed functions * +;************************************************************************ + public call_clo +call_clo: mov AX, offset PGROUP:next_PC ; For a "CALL-CLOSURE" make a tail + push AX ; recursive call to the following routine + + lods word ptr ES:[SI] ; fetch ftn reg, number of args passed +cl_c_sub: mov BL,AH ; isolate the number of arguments + push BX ; passed and save it + mov BL,AL ; copy the procedure object register + mov DI,reg0_pag+[BX] ; load page number of closure pointer + cmp byte ptr ptype+[DI],CLOSTYPE*2 + je call_cok ; if a regular closure, jump + jmp call_cnt ; otherwise, a continuation (probably) +; Procedure call to a closed procedure +call_cok: push BX ; save number of procedure pointer reg + call new_SF ; allocate a new stack frame + pop SI ; restore reg number with closure pointer + +; Load the pointer to the closure object from the operand register +call_xxx: mov clos_ptr,SI ; save number of register containing closure + mov DI,reg0_pag+[SI] + mov SI,reg0_dis+[SI] + LoadPage ES,DI +;;; mov ES,pagetabl+[DI] + +; Put the closure pointer into the newly allocated stack frame + mov AX,DI ; copy closure's page number to AL + mov S_stack+[BX].sf_cl_pg,AL ; then copy into stack frame + mov word ptr S_stack+[BX].sf_cl_ds,SI ; put disp into frame, too + +; Copy the pointer to the procedure's heap environment from the closure +; object to the new stack frame + mov AL,ES:[SI].clo_hpag + mov S_stack+[BX].sf_hpage,AL + mov AX,ES:[SI].clo_hdis + mov word ptr S_stack+[BX].sf_hdisp,AX + +; Dummy up the Static Link in the new Stack Frame + mov word ptr S_stack+[BX].sf_sdisp,0 + +; Update the current frame pointer to point to new stack frame + mov FP,BX + +; Obtain the entry point address from the closure object + mov AX,ES:[SI].clo_cb_d ; define the code base register + mov CB_dis,AX + add AX,ES:[SI].clo_edis ; add the entry point offset + mov [BP].save_SI,AX ; and set up for load into location pointer + xor AX,AX + mov AL,ES:[SI].clo_cb_p + mov byte ptr CB_pag,AL + mov DI,AX ; obtain the code block page's paragraph + LoadCode AX,DI +;;; mov AX,pagetabl+[DI] ; address and update in memory + mov [BP].save_ES,AX + +; Determine if the closed function is a mulambda + pop CX ; get number of args passed + mov AX,ES:[SI].clo_narg ; load number of args expected + shl AX,1 ; sign extend the number of + sar AX,1 ; arguments expected + jl call_mu ; if #args negative, then a mulambda (jump) + cmp AX,CX ; verify args passed/expected agree + je call_crt ; if so, jump + +; ***Error-- wrong number of arguments passed to a closed function*** +cl_wrng: mov AX,clos_ptr ; load number of register w/ closure pointer + add AX,offset reg0 + pushm ; push count of args passed, closure ptr +cl_wrng1: C_call wrong_ar,,Load_ES ; print error message and fixup VM regs + restore ; load address of next instruction + jmp sch_err ; link to Scheme error routine + +call_crt: ret ; return to interpreter, or call/cc support + +; Funtion being called is a mulambda-- cons arguments into a list +call_mu: mov SI,CX ; compute the address of the last + sal SI,1 ; register which contains an argument + sal SI,1 ; to be passed to the mulambda + add SI,offset reg0 + + lea DI,[SI]+size C_ptr ; load address of register page last arg + mov [DI].C_page,NIL_PAGE*2 ; put a value of "nil" into the + mov [DI].C_disp,NIL_DISP ; register for end of list + + mov ES,[BP].C_ES ; set up ES for calls to "cons" + + mov DX,CX ; save number of arguments passed + add CX,AX ; adjust number of arguments passed + inc CX ; by number required + je mu_ret ; if #passed = #required, jump + jl mu_wrng ; if too few passed, jump + +mu_loop: push DI ; push addr of "cdr" register + push SI ; push addr of "car" register + push SI ; push addr of dest reg (result of cons) + C_call cons, ; cons together ptrs in regs "n" and "n+1" + add SP,WORDINCR ; drop one copy of SI from the 8088's stack + pop SI ; restore value of SI + pop DI ; restore value of DI + restore ; restore registers destroyed by the call + mov [DI].C_page,UN_PAGE*2 ; set register "n+1" to "***unbound***" + mov [DI].C_disp,UN_DISP + mov DI,SI ; update pointers for next iteration + sub SI,size C_ptr + loop mu_loop ; repeat for all arguments passed + +mu_ret: ret ; return to interpreter, or call/cc support + +; Too few required arguments-- inform user +mu_wrng: mov CX,DX ; restore count of args passed + jmp cl_wrng ; print "wrong number of args" message + +; Function call is invoking a continuation-- unless we've got an error +call_cnt: cmp ptype+[DI],CONTTYPE*2 + je cl_cn_ok +; ***Error-- thing being called isn't a procedure object-- note*** +; Note: at this point, the number of arguments passed has been pushed +; onto the runtime stack + add BX,offset reg0 ; compute address of "functional" register + push BX ; and push as argument + C_call not_proc,,Load_ES ; call: not_procedural_object(obj, #args); + restore ; load address of next instruction + jmp sch_err ; link to Scheme debugger + +; Oh, wow! we've got a continuation to envoke (or is that invoke?) +; +; Note: the contents of the stack is restored by making the VM's +; previous stack segment register point to the continuation +; object and signaling an underflow condition. This restores +; the stack, BASE, TOS, PREV_pag, and PREV_dis. The +; remainder of this code fetches the values of CB_pag, +; CB_dis, FP, and LP from the continuation object. +; +cl_cn_ok: push BX ; save pointer to continuation object + mov AL,byte ptr reg0_pag+[BX] ; copy continuation pointer into + mov byte ptr PREV_pag,AL ; PREV_reg + mov AX,reg0_dis+[BX] + mov PREV_dis,AX + + call stk_unfl ; signal a stack underflow condition + + pop DI ; retrieve ptr to reg with continuation ptr. + mov SI,reg0_pag+[DI] ; make ES:[SI] point to the continuation + LoadPage ES,SI +;;; mov ES,pagetabl+[SI] ; object + mov SI,reg0_dis+[DI] + + xor BX,BX + mov BL,ES:[SI].con_cb_p + mov byte ptr CB_pag,BL + LoadCode AX,BX +;;; mov AX,pagetabl+[BX] ; obtain the code block's paragraph address + mov [BP].save_ES,AX + mov AX,ES:[SI].con_cb_d ; restore code base pointer + mov CB_dis,AX + + add AX,ES:[SI].con_ret ; restore return address displacement + mov [BP].save_SI,AX + + mov AX,ES:[SI].con_ddis ; restore FP from dynamic link + sub AX,BASE ; adjust for current stack buffer base + mov FP,AX + + mov AL,ES:[SI].con_fl_p ; restore fluid environment (FNV_reg) + mov byte ptr FNV_pag,AL + mov AX,ES:[SI].con_fl_d + mov FNV_dis,AX + + mov AL,ES:[SI].con_gl_p ; restore global environment (GNV_reg) + mov byte ptr GNV_pag,AL + mov AX,ES:[SI].con_gl_d + mov GNV_dis,AX + + pop AX ; get number of arguments passed + cmp AX,1 ; one argument passed? + jne cl_cn_er ; if so, good! we can continue (fall thru) +cl_cn_rt: ret ; return to interpreter, or call/cc support + +; ***error-- wrong number of arguments passed to a continuation*** +cl_cn_er: add DI,offset reg0 ; load address of continuation's register + pushm ; push continuation ptr, args passed + jmp cl_wrng1 ; process error condition + + +;************************************************************************ +;* AL AH * +;* Call closed proc tail recursively CALL-CLOSURE-TR ftn,#args * +;* * +;* Purpose: Scheme interpreter support for procedure calls to fully * +;* closed functions tail recursively * +;************************************************************************ + public call_ctr +call_ctr: mov AX,offset PGROUP:next_PC ; For "CALL-CLOSURE-TR" make tail + push AX ; recursive call to the following routine + + lods word ptr ES:[SI] ; fetch ftn reg, number of args passed +cl_ct_sb: mov BL,AH ; isolate the number of arguments + push BX ; passed and save it + mov BL,AL ; copy the procedure object register + mov DI,reg0_pag+[BX] ; load page number of procedure object + cmp ptype+[DI],CLOSTYPE*2 ; is it a closure data object? + je call_cko ; if a regular closure, jump + jmp call_cnt ; otherwise, a continuation (probably) + +; Procedure call (tail recursive) to a closed procedure +call_cko: mov SI,BX ; copy reg number with closure pointer + mov AX,FP ; use current stack frame for this call + mov BX,AX ; drop any local vars from top of stack + add AX,SF_OVHD-PTRSIZE + mov TOS,AX ; update TOS pointer + + jmp call_xxx ; continue processing as non-tr call + + +;************************************************************************ +;* Call/cc local CALL/CC lbl,delta-lvl,delta-heap* +;* * +;* Purpose: Interpreter support for a local call with current * +;* continuation * +;* * +;* Description: * +;* 1. The local CALL support is called to create a new * +;* stack frame and to establish the VM's registers * +;* for the branch to the called routine. * +;* 2. A stack overflow condition is signaled to cause * +;* the contents of the stack to be saved on the heap * +;* in a continuation object format. * +;* 3. Fields in the continuation object are updated to * +;* cause control to return to the correct place when * +;* the continuation is invoked. * +;* 4. Control returns to the Scheme interpreter. * +;************************************************************************ + public call_cc +call_cc: call cl_l_sub ; call CALL's alternate entry point + +call_cc1: call stk_ovfl ; signal stack overflow + + mov BX,PREV_pag ; move pointer to continuation into R1 + mov DI,PREV_dis + mov reg1_pag,BX + mov reg1_dis,DI + LoadPage ES,BX +;;; mov ES,pagetabl+[BX] + + mov SI,FP ; create a pointer to the current stack + add SI,offset S_stack ; frame (the new one) + + mov AL,[SI].sf_cb_pag ; copy the value of the VM's code base + mov ES:[DI].con_cb_p,AL ; into the continuation object + mov AX,[SI].sf_cb_dis + mov ES:[DI].con_cb_d,AX + + mov AX,[SI].sf_ret ; copy the return address displacement + mov ES:[DI].con_ret,AX ; into the continuation object + + mov AX,[SI].sf_ddisp ; copy the dynamic link into the + mov ES:[DI].con_ddis,AX ; continuation object + + jmp next_PC ; return to the interpreter + +;************************************************************************ +;* Call/cc tail recursively CALL/CC-TR lbl,delta-lvl,delta-heap* +;* * +;* Purpose: Interpreter support for a tail recursive local call with * +;* current continuation * +;* * +;* Description: * +;* 1. The local CALL-TR support is called to update the * +;* current stack frame and to establish the VM's * +;* registers for the branch to the called routine. * +;* 2. Control transfers to the CALL/CC support to create * +;* the continuation object. * +;************************************************************************ + public cl_cctr +cl_cctr: mov AX,offset PGROUP:call_cc1 ; define return address + push AX + jmp cl_lt_sb ; tail recursive call to CALL-TR's + ; secondary entry point + + +;************************************************************************ +;* AL * +;* Call/cc with of procedure object CALL/CC-CLOSURE ftn * +;* * +;* Purpose: Interpreter support for a call with current continuation * +;* of a fully closed function * +;* * +;************************************************************************ + public clcc_c +clcc_c: lods byte ptr ES:[SI] ; load register number pointing to closure + mov AH,1 ; indicate one argument being passed + push AX ; and save "operands" + + mov AX,FP ; save current stack frame pointer + add AX,BASE + push AX + + mov AX,TOS ; update FP to where it will be after + add AX,PTRSIZE ; the new stack frame is built + mov FP,AX + + call stk_ovfl ; signal stack overflow to create + ; continuation data object + + mov BX,PREV_pag ; load pointer to continuation + mov DI,PREV_dis + LoadPage ES,BX +;;; mov ES,pagetabl+[BX] + + mov AL,byte ptr CB_pag ; copy the value of the VM's code base + mov ES:[DI].con_cb_p,AL ; into the continuation object + mov AX,CB_dis + mov ES:[DI].con_cb_d,AX + + sub SI,AX + mov ES:[DI].con_ret,SI ; place return addr in continuation object + add SI,AX + + pop AX ; define dynamic link in continuation + mov ES:[DI].con_ddis,AX ; object + sub AX,BASE ; put FP back to where it should be + mov FP,AX ; Note: FP's now negative (TOS is 0) + +; Perform the Call-Closure-Tail-Recursive + mov AL,byte ptr PREV_pag ; save the pointer to the new + mov byte ptr tm2_page,AL ; continuation + mov AX,PREV_dis + mov tm2_disp,AX + pop AX ; recover "operands" to call-closure + call cl_c_sub ; call CALL-CLOSURE + mov AL,byte ptr tm2_page ; move continuation pointer into + mov byte ptr reg1_pag,AL ; VM register R1 + mov AX,tm2_disp + mov reg1_dis,AX + jmp next_PC ; return to interpreter + + + +;************************************************************************ +;* AL * +;* Call/cc with of procedure object CALL/CC-CLOSURE-TR ftn * +;* * +;* Purpose: Interpreter support for a tail recursive call with current * +;* continuation of a fully closed function * +;* * +;* Description: * +;* 1. The CALL/CC-CLOSURE argument is fetched. * +;* 2. The current continuation is formed using the * +;* caller's return address (since there's no way to * +;* return here from the tail recursive call). * +;* The pointer to the continuation is placed into * +;* VM register 1. * +;* 3. The CALL-CLOSURE-TR code is called to complete the * +;* call sequence. * +;************************************************************************ + public clcc_ctr +clcc_ctr: lods byte ptr ES:[SI] ; load register number pointing to closure + mov AH,1 ; indicate one argument being passed + push AX ; and save "operands" + + call stk_ovfl ; signal stack overflow to create + ; continuation data object + + mov BX,PREV_pag ; load pointer to continuation + mov DI,PREV_dis + LoadPage ES,BX +;;; mov ES,pagetabl+[BX] + + mov SI,FP ; create a pointer to the current stack + add SI,offset S_stack ; frame (the new one) + + mov AL,[SI].sf_cb_pag ; copy the value of the VM's code base + mov ES:[DI].con_cb_p,AL ; into the continuation object + mov AX,[SI].sf_cb_dis + mov ES:[DI].con_cb_d,AX + + mov AX,[SI].sf_ret ; copy the return address displacement + mov ES:[DI].con_ret,AX ; into the continuation object + + mov AX,[SI].sf_ddisp ; copy the dynamic link into the + mov ES:[DI].con_ddis,AX ; continuation object + +; Perform the Call-Closure-Tail-Recursive + mov AL,byte ptr PREV_pag ; save the pointer to the new + mov byte ptr tm2_page,AL ; continuation + mov AX,PREV_dis + mov tm2_disp,AX + pop AX ; recover "operands" to call-closure-tr + call cl_ct_sb ; call CALL-CLOSURE-TR + mov AL,byte ptr tm2_page ; move continuation pointer into + mov byte ptr reg1_pag,AL ; VM register R1 + mov AX,tm2_disp + mov reg1_dis,AX + jmp next_PC ; return to interpreter + + +;************************************************************************ +;* AL AH * +;* Apply closure APPLY-CLOSURE ftn,args * +;* * +;* Purpose: Interpreter support for the "apply" primitive. The * +;* argument list (in register "args") are to be passed * +;* to the closure pointed to by the "ftn" register. * +;* * +;* Note: The argument registers may be anything that the compiler * +;* decides on, so the "ftn" pointer could be destroyed * +;* in the process of loading the arguments of the argument * +;* list ("args") into the VM general registers R1-Rn. * +;* So that the ftn pointer is not lost during this process,* +;* this pointer is pushed onto the 8088 stack before the * +;* call to process the arguments, and it is restored into * +;* the last available register to complete the call * +;* sequence. * +;* * +;* Garbage collection will not occur during the argument loading * +;* process (arguments are copied, but no cons-ing occurs), * +;* so it's safe to save the "ftn" pointer on the 8088 * +;* stack temporarily. * +;************************************************************************ +last_pag equ reg0_pag + (NUM_REGS - 1) * size C_ptr +last_dis equ reg0_dis + (NUM_REGS - 1) * size C_ptr + public apply +apply: lods word ptr ES:[SI] ; load apply's arguments + mov BL,AL ; copy closure pointer register number + push reg0_pag+[BX] ; save value of register containing + push reg0_dis+[BX] ; the closure pointer + save ; save registers across call + call aply_arg ; expand arguments into R1-Rn + restore ; restore saved registers + pop last_dis ; put "ftn" pointer into last VM register + pop last_pag + mov AH,CL ; copy the argument count to AH, AL<="Rlast" + mov AL,(NUM_REGS - 1) * size C_ptr + call cl_c_sub ; process the call + jmp next_PC ; return to the interpreter + + +;************************************************************************ +;* AL AH * +;* Apply closure, tail recursively APPLY-CLOSURE-TR ftn,args * +;* * +;* Purpose: Interpreter support for the "apply" primitive. The * +;* argument list (in register "args") are to be passed * +;* to the closure pointed to by the "ftn" register. * +;* * +;* Note: See notes in "APPLY-CLOSURE" support, above. * +;************************************************************************ + public apply_tr +apply_tr: lods word ptr ES:[SI] ; load apply-tr's arguments + mov BL,AL ; copy closure pointer register number + push reg0_pag+[BX] ; save value of register containing + push reg0_dis+[BX] ; the closure pointer + save ; save registers across call + call aply_arg ; expand arguments into R1-Rn + restore ; restore saved registers + pop last_dis ; put "ftn" pointer into last VM register + pop last_pag + mov AH,CL ; copy the argument count to AH, AL<="Rlast" + mov AL,(NUM_REGS - 1) * size C_ptr + call cl_ct_sb ; process the call, tail recursively + jmp next_PC ; return to the interpreter + +;************************************************************************ +;* Execute code block EXECUTE CODE * +;* * +;* Purpose: Interpreter support for the "execute" primitive operation. * +;* * +;* Description: The execute primitive causes a code block to be * +;* executed in a new environment. This is accomplished * +;* by executing a procedure call to the code block with * +;* no static environment information available. The * +;* new stack frame has a nil heap environment pointer, and * +;* the static link is set to point to itself to prevent * +;* access to any higher lexical levels. When the code * +;* block exits, control will return to the place where the * +;* execute instruction was executed. * +;************************************************************************ + public execute +execute: lods byte ptr ES:[SI] ; fetch register number with code pointer + mov BX,AX +execute1 label far + mov DI,reg0_pag+[BX] + cmp byte ptr ptype+[DI],CODETYPE*2 ; pointer to code block? + jne load_ex1 ; if not, we've got to load before execute + push BX ; save the code pointer's register number + call new_SF ; create a new stack frame for the "call" + mov word ptr S_stack+[BX].sf_sdisp,0 ; make "nil" static link + mov AL,byte ptr GNV_pag ; default environment to global env + mov S_stack+[BX].sf_hpage,AL + mov AX,GNV_dis + mov word ptr S_stack+[BX].sf_hdisp,AX + mov FP,BX + pop BX ; retrieve the code pointer's reg number + mov SI,reg0_dis+[BX] ; define the code base register + mov CB_dis,SI + mov BL,byte ptr reg0_pag+[BX] + mov byte ptr CB_pag,BL + LoadCode ES,BX +;;; mov ES,pagetabl+[BX] ; load the code base page's para address + save ; and save it off + add SI,ES:[SI].cod_entr ; adjust location ptr for entry offset + jmp next ; return to the interpreter + +load_ex1: jmp far ptr load_ex ; long jump to loader +; +; Object to be executed is not a code block, so we've got to create +; one for a compiled program before executing it. The format of an +; object program is: +; +; (tag #-constants #-codebytes (constant ...) (codebyte ...)) +; +; ***Error-- Invalid Object Module Format*** +bad_obj2 label far + mov AX,offset m_%exec ; load addr of "%EXECUTE" + restore ; load number of register containing + add BX,offset reg0 ; the "code" pointer and compute its addr + mov CX,1 ; load argument count = 1 + pushm ; push arguments to set_src_err + C_call set_src_ ; call: set_src_err("%EXECUTE", 1, code) + restore ; load next instruction's location + jmp sch_err ; link to Scheme debugger + +;************************************************************************ +;* Exit from current procedure EXIT * +;* * +;* Description: The internal registers of the VM are reset from * +;* information stored in the current frame pointer to * +;* restore the environment at the point where the current * +;* procedure was called (i.e., control returns to the * +;* calling routine). * +;************************************************************************ + public s_exit +s_exit: mov AX,FP ; load the current frame pointer + mov BX,AX + add BX,offset S_stack ; compute address of current stack frame + + sub AX,PTRSIZE ; reset the current TOS to previous + mov TOS,AX ; value [FP - sizeof(pointer)] + + xor AX,AX ; clear AX + mov AL,[BX].sf_cb_pag ; load CB's page number + mov byte ptr CB_pag,AL + mov DI,AX ; save code block's page number + LoadCode ES,DI +;;; mov ES,pagetabl+[DI] ; set paragraph address of page containing + save ; calling routine's code block + mov AX,[BX].sf_cb_dis ; update the current code base (CB) + mov CB_dis,AX + + add AX,[BX].sf_ret ; load return address' location pointer + mov SI,AX ; and add in starting offset of code block + + mov AX,[BX].sf_ddisp ; compute pointer to caller's stack frame + cmp AX,BASE ; is new FP outside stack buffer? + jae s_exit_1 ; if in bounds, jump + pushm ; save new FP, new location pointer + call stk_unfl ; process stack underflow + popm ; restore saved new FP, new location pointer +s_exit_1: sub AX,BASE ; FP <- dynamic link - Base + mov FP,AX + jmp next ; return to interpreter + +stk_int endp + +;************************************************************************ +;* AL AL AH * +;* Create Closure CR-CLOSE dest,label,nargs * +;* * +;* Purpose: Scheme interpreter support for the creation of closure * +;* objects. * +;************************************************************************ + public cr_close +cr_close: lods byte ptr ES:[SI] ; load destination register number + mov DI,AX ; and save it for now + lods word ptr ES:[SI] ; load address of entry label + mov CX,AX ; and save it, too + lods byte ptr ES:[SI] ; load number of arguments and + cbw ; convert it to a fullword integer + shl AX,1 ; clear high order bit of immediate value + shr AX,1 + add CX,SI ; add in current location pointer + sub CX,CB_dis ; and adjust for code block offset + save ; save nargs, entry point, location pointer + mov DX,CLOSTYPE ; load tag=closure + mov AX,CLO_OVHD-PTRSIZE ; load size of closure object + pushm ; push arguments + C_call alloc_bl,,Load_ES ; call: alloc_block(®, type, size) + mov SP,BP ; drop arguments off TIPC's stack + + mov BX,tmp_page ; load pointer to closure object + mov DI,tmp_disp + LoadPage ES,BX +;;; mov ES,pagetabl+[BX] + + mov SI,[BP].save_DI ; copy contents of destination register + xchg BL,byte ptr reg0_pag+[SI] ; into the information operand of + mov ES:[DI].clo_ipag,BL ; the newly allocated closure object. + mov AX,DI ; Make the destination register point + xchg AX,reg0_dis+[SI] ; to the closure object. + mov ES:[DI].clo_idis,AX + + mov AL,SPECFIX*2 ; set tags for constant fields + mov ES:[DI].clo_etag,AL ; entry point tag=fixnum + mov ES:[DI].clo_atag,AL ; nargs tag=fixnum + + mov AL,byte ptr CB_pag ; copy in pointer to current code base + mov ES:[DI].clo_cb_p,AL + mov AX,CB_dis + mov ES:[DI].clo_cb_d,AX + + restore ; define entry point offset + mov ES:[DI].clo_edis,CX + + restore ; define number of arguments + mov ES:[DI].clo_narg,AX + + mov SI,FP ; load pointer to current stack frame + mov AL,S_stack+[SI].sf_hpage ; define heap environment + mov ES:[DI].clo_hpag,AL + mov AX,word ptr S_stack+[SI].sf_hdisp + mov ES:[DI].clo_hdis,AX + + jmp next_PC ; return to interpreter + + +;************************************************************************ +;* Local support - stack overflow handler * +;* * +;* Purpose: To move part of Scheme's runtime stack to the heap when * +;* stack overflow occurs. * +;* * +;* Description: The contents of the stack which precede the current * +;* stack frame are moved to the heap (in a continuation * +;* object) and the current stack frame is moved to the * +;* top of the stack buffer. * +;* * +;* Input Parameters: * +;* TIPC register SI - the value to be placed in the * +;* "return address displacement" field of the * +;* continuation (needed only for call/cc) * +;* FNV_reg - the current fluid environment (saved by * +;* call/cc) * +;* GNV_reg - the current global environment (saved by * +;* call/cc) +;* FP - the current stack frame pointer * +;* BASE - the stack buffer base value * +;* TOS - the current top-of-stack pointer * +;* CB - the VM register which points to the current * +;* code block * +;* PREV_pag,PREV_dis - the VM's previous stack segment * +;* register * +;* * +;* Output Parameters: * +;* PREV_pag,PREV_dis - a pointer to the continuation * +;* object which was created * +;* BASE - updated to the new base value (stack offset) * +;* due to movement of some of the stack contents * +;* to the heap * +;* * +;* Variables Modified: (but logically unchanged) * +;* FP - the current stack frame pointer * +;* TOS - the current top of stack pointer * +;* * +;* Example: Stack Overflow Condition * +;* * +;* Before * +;* * +;* +--------+-----------------+ * +;* | prev stk seg -> = nil | * +;* +--------+-----------------+ * +;* Stack Buffer (BASE = 0) * +;* +--------+-----------------+ * +;* | Contents | * +;* : of : * +;* : Stack : * +;* | (m bytes) | * +;* |--------+-----------------| * +;* | Current |<-FP * +;* : Stack : * +;* | Frame |<-TOS * +;* +--------+-----------------+ * +;* * +;* AFTER * +;* * +;* "Continuation" in Heap * +;* +--------+-----------------+ +--------+-----------------+ * +;* | prev stk seg -> |------->| cont | length (m+24) | * +;* +--------+-----------------+ |--------+-----------------| * +;* Stack Buffer (BASE = m) | segment's stack base = 0 | * +;* +--------+-----------------+ |--------+-----------------| * +;* | Current |<-FP | code base -> = n/a | * +;* : Stack : |--------+-----------------| * +;* | Frame |<-TOS | return addr disp = n/a | * +;* |--------+-----------------| |--------+-----------------| * +;* | unused stack | | caller dynamic link = n/a| * +;* : : |--------+-----------------| * +;* : : | fluid env -> = FNV_reg | * +;* | | |--------------------------| * +;* +--------+-----------------+ | prev stk seg -> = nil | * +;* |--------+-----------------| * +;* | global env -> = GNV_reg | * +;* |--------+-----------------| * +;* | Contents | * +;* : of : * +;* : Stack : * +;* | (m bytes) | * +;* +--------+-----------------+ * +;* * +;* Notes: This routine handles both routine stack overflow, and stack * +;* overflow which is signaled during the creation of a * +;* full continuation because of a call/cc. All of the * +;* fields of the continuation object are filled in by this * +;* routine, but they are meaningless and will never be * +;* used in the case of simple stack overflow. * +;************************************************************************ +stk_arg struc +stk_temp dd ? ; temporary register +stk_SI dw ? ; caller's SI (for continuation, rtn addr) +stk_BP dw ? ; caller's BP + dw ? ; return address +stk_arg ends + +stk_ovfl proc near + push BP ; save caller's BP + sub SP,offset stk_BP + mov BP,SP + mov [BP].stk_SI,SI ; save return address disp, if meaningful + +; test to see how to create continuation object + mov CX,FP ; load current frame pointer, + cmp CX,0 ; length of stack contents zero? + jg stk_nz ; if not, create new continuation (jump) + +; copy previous continuation + mov AX,PREV_pag ; tmp_reg <- PREV_reg + mov tmp_page,AX + mov AX,PREV_dis + mov tmp_disp,AX + mov AX,offset PREV_reg ; load address of PREV_reg, tmp_reg + pushm ; push as arguments + C_call copy_blk ; call: copy_blk(&PREV_reg, &tmp_reg) + mov SP,BP ; drop arguments from stack + jmp stk_rtn ; return copy of previous continuation + +; print warning concerning impending stack overflow +s_toobig: pushm ; save active registers + lea BX,m_stk_ov ; load error message text address + push BX ; and push as argument to printf + C_call printf,,Load_ES ; call: printf("***error... "); + pop BX ; drop argument from TIPC's stack + C_call force_de ; call: force_debug(); + popm ; restore active registers + jmp stk_go ; continue executing where we left off + +; allocate a continuation object on the heap +stk_nz: add CX,offset con_data-PTRSIZE ; and compute continuation's size + mov DX,CONTTYPE ; load tag=CONTTYPE + lea BX,[BP].stk_temp ; load address of temporary result reg + pushm ; push arguments, and call + mov BX,DS ; set up ES segment register for C_call + mov ES,BX + C_call alloc_bl ; "alloc_block(®,CONTTYPE,len)" + mov SP,BP ; remove arguments from 8088's stack + +; load pointer to the continuation object just allocated + mov CX,FP ; reload length of continuations stack data + mov BX,[BP].stk_temp.C_page ; load returned pointer to + mov DI,[BP].stk_temp.C_disp ; continuation object + LoadPage ES,BX +;;; mov ES,pagetabl+[BX] ; ES->continuation object's page + +; define continuation object fields + mov AL,SPECFIX*2 + mov ES:[DI].con_btag,AL ; stack base tag=fixnum + mov ES:[DI].con_rtag,AL ; return address tag=fixnum + mov ES:[DI].con_dtag,AL ; dynamic link tag=fixnum + + mov AL,byte ptr CB_pag ; define code base pointer + mov ES:[DI].con_cb_p,AL + mov AX,CB_dis + mov ES:[DI].con_cb_d,AX + + neg AX ; subtract CB_dis from SI + add AX,[BP].stk_SI ; use contents of SI for return addr disp + mov ES:[DI].con_ret,AX + + mov AX,FP ; define dynamic link + mov ES:[DI].con_ddis,AX + + mov AX,BASE ; set continuation's stack base + mov ES:[DI].con_base,AX + add AX,CX ; compute new stack buffer base + mov BASE,AX ; [BASE <- BASE + FP] + +; Test for impending stack overflow + cmp AX,-STKSIZE ; over stack buffer threshold? + jae s_toobig ; if so, print warning (jump) + +stk_go: mov AL,byte ptr FNV_pag ; set fluild environment pointer + mov ES:[DI].con_fl_p,AL + mov AX,FNV_dis + mov ES:[DI].con_fl_d,AX + + mov AL,byte ptr GNV_pag ; set global environment pointer + mov ES:[DI].con_gl_p,AL + mov AX,GNV_dis + mov ES:[DI].con_gl_d,AX + + mov AX,PREV_pag ; set previous stack segment pointer + mov ES:[DI].con_spag,AL + mov AX,PREV_dis + mov ES:[DI].con_sdis,AX + + mov PREV_pag,BX ; make previous stack segment register + mov PREV_dis,DI ; point to the new continuation object + +; update the counter of bytes transfered to the heap + add word ptr stk_out,CX ; record number of bytes transfered + adc word ptr stk_out+2,0 ; fix up high order part of sum + +; move stack data to continuation object in the heap + lea SI,S_stack ; load stack address + add DI,offset con_data ; adjust for continuation header info + mov DX,CX ; copy length (in bytes) and + and DX,1 ; isolate lsb for fixup + shr CX,1 ; convert bytes to words + cld ; clear direction flag (forward move) +rep movsw ; move stack contents to heap (cont obj) + mov CX,DX ; copy fixup length (0 or 1 bytes) +rep movsb ; copy remaining byte, if needed + +; move data in current stack frame to top of stack buffer + lea SI,S_stack ; load address of top of stack buffer + mov DI,SI ; DI <- top of stack buffer (0) + add SI,FP ; SI <- current stack frame + mov CX,DS + mov ES,CX ; ES->data segment + mov CX,TOS ; load current top of stack, + sub CX,FP ; subtract bytes moved to heap, + mov TOS,CX ; and define new TOS + add CX,PTRSIZE ; compute bytes of stack to move up + mov DX,CX ; copy length (in bytes) and + and DX,1 ; isolate lsb for fixup + shr CX,1 ; convert bytes to words +rep movsw ; move stack contents to top of stack buffer + mov CX,DX ; copy fixup length (0 or 1 bytes) +rep movsb ; copy remaining byte, if needed + + mov FP,0 ; current frame now at top of stack buffer + +; return to caller +stk_rtn: mov SI,[BP].stk_SI ; restore return address disp, if meaningful + add SP,offset stk_BP ; drop local variable storage + pop BP ; restore caller's BP + ret ; return +stk_ovfl endp + +;************************************************************************ +;* Local support - stack underflow handler * +;* * +;* Purpose: To restore segments of the stack, which previously have * +;* been moved to the heap, back into the stack buffer. * +;* * +;* Description: Previously saved stack segments (moved to the heap * +;* as the result of a stack overflow or a call/cc) are * +;* represented as continuation data objects. When this * +;* routine is called, a "stack underflow" has occurred * +;* as an "EXIT" operation needs to access a stack frame * +;* higher in the stack, so data fields with a call/cc * +;* continuation are ignored. * +;************************************************************************ +stk_unfl proc near + push BP ; save caller's BP + mov BP,SP + mov BX,PREV_pag ; fetch previous stack segment's page number + cmp BX,0 ; stack link nil? + je unfl_nil ; if so, jump (real stack underflow) + mov SI,PREV_dis ; load previous stack segment displacement + + push DS ; save caller's DS register + mov CX,DS + mov ES,CX ; ES->stack's data group + LoadPage DS,BX +;;; mov DS,pagetabl+[BX] ; DS->continuation object's page + + mov AX,[SI].con_base ; update stack buffer's base + mov ES:BASE,AX + + mov AL,[SI].con_spag ; update previous stack segment register + mov ES:byte ptr PREV_pag,AL + mov AX,[SI].con_sdis + mov ES:PREV_dis,AX + + mov CX,[SI].con_len ; load length of saved stack data + sub CX,offset con_data ; adjust length for continuation header + add SI,offset con_data ; adjust offset for continuation header + lea DI,S_stack ; load address of bottom of stack + mov DX,CX ; compute new top of stack + sub DX,PTRSIZE + mov ES:TOS,DX ; in memory (temporarily covered by ES) + + add word ptr ES:stk_in,CX ; update count of bytes transfered + adc word ptr ES:stk_in+2,0 ; fix up high order part of counter + + mov DX,CX ; copy the length (in bytes) + and DX,1 ; and determine fixup (0 or 1 bytes) + shr CX,1 ; convert length from bytes to words + cld ; set direction flag = forward +rep movsw ; restore the stack's contents + mov CX,DX ; copy fixup length and +rep movsb ; move the odd byte, if needed + pop DS ; restore DS + pop BP + ret ; return to caller +; Error-- stack underflow +unfl_nil: lea BX,m_stk_un + push BX + C_call printf,,Load_ES + C_call exit +stk_unfl endp + + +;************************************************************************ +;* Local support - Create new stack frame * +;* * +;* Purpose: To create and partially define a new stack frame prior * +;* to a procedure call * +;* * +;* Description: This routine allocates space on the top of the stack * +;* for a new stack frame and defines the following fields: * +;* * +;* code base pointer <- CB * +;* return addr disp <- SI (contents of reg) * +;* dynamic link <- FP * +;* static link's tag <- fixnum * +;* heap env <- current heap env * +;* static link <- current static link * +;* closure pointer <- nil (implies an open call) * +;* * +;* Input Parameters: * +;* TIPC register SI - the VM's location pointer * +;* CB_pag,CB_dis - the VM's code base register * +;* FP - the VM's current frame pointer * +;* TOS - the VM's top of stack pointer * +;* * +;* Output Parameters: * +;* TIPC register BX - pointer to new stack frame * +;* (displacement in stack) * +;* TOS - top of stack pointer updated for new stack length * +;* * +;* Variables Modified: The following variables will be modified if * +;* a stack overflow occurs during the push operation for * +;* the new stack frame: * +;* * +;* FP - the VM's current frame pointer(logically unchanged)* +;* BASE - the VM's stack buffer base * +;* PREV_pag,PREV_dis - the VM's previous stack segment reg * +;************************************************************************ +new_SF proc near + mov AX,TOS ; load current top of stack pointer + mov BX,AX ; and make a copy + add AX,SF_OVHD ; increment TOS by size of stack frame + cmp AX,STKSIZE-PTRSIZE ; is there room on stack for new frame? + jg new_FP_1 ; if not, process stack overflow (jump) + mov TOS,AX ; update top of stack pointer + add BX,PTRSIZE ; compute pointer to new stack frame + + mov AL,SPECFIX*2 ; load tag for fixnum's + mov S_stack+[BX].sf_rtag,AL ; return address tag=fixnum + mov S_stack+[BX].sf_dtag,AL ; dynamic link tag=fixnum + mov S_stack+[BX].sf_stag,AL ; static link tag=fixnum + + xor AX,AX ; store '() into closure pointer + mov S_stack+[BX].sf_cl_pg,AL + mov word ptr S_stack+[BX].sf_cl_ds,AX + + mov AL,byte ptr CB_pag ; move current code base pointer + mov S_stack+[BX].sf_cb_pag,AL ; into the new stack frame + mov AX,CB_dis + mov word ptr S_stack+[BX].sf_cb_dis,AX + + sub SI,AX ; compute ret addr relative to code block + mov word ptr S_stack+[BX].sf_ret,SI ; record the return address + add SI,AX ; restore SI + +; copy the current heap environment pointer to the new stack frame + mov DI,FP ; load the current stack frame pointer + mov AL,S_stack+[DI].sf_hpage + mov S_stack+[BX].sf_hpage,AL + mov AX,word ptr S_stack+[DI].sf_hdisp + mov word ptr S_stack+[BX].sf_hdisp,AX + +; copy the static link from the current frame to the new one + mov AX,word ptr S_stack+[DI].sf_sdisp + mov word ptr S_stack+[BX].sf_sdisp,AX + +; define the dynamic link field + add DI,BASE + mov word ptr S_stack+[BX].sf_ddisp,DI + + ret ; return to the caller + +; Process stack overflow +new_FP_1: push SI ; save current location pointer + call stk_ovfl ; process the overflow + pop SI ; restore location pointer + jmp new_SF ; try again to allocate new stack frame +new_SF endp + + +;************************************************************************ +;* Local support - drop items from the heap environment * +;* * +;* Purpose: To drop "n" items off the local heap environment * +;* * +;* Input Parameters: * +;* TIPC register CX - the number of items to drop * +;* FP - the current stack frame pointer * +;* * +;* Output Parameters: * +;* TIPC register BX - page number for the remaining * +;* heap environment list * +;* TIPC register DI - displacement pointer for the * +;* remaining heap environment * +;* * +;* Registers/Variables Modified: * +;* CX - decremented to zero * +;* TIPC register ES - contents undefined * +;************************************************************************ +delta_hp proc near + mov DI,FP ; load the current stack frame pointer + xor BX,BX ; clear register BX + mov BL,S_stack+[DI].sf_hpage ; load the current heap environment + mov DI,word ptr S_stack+[DI].sf_hdisp ; pointer + cmp CX,0 ; drop zero elements? + jle del_h_rt ; if drop zero, jump +del_h_lp: LoadPage ES,BX +;;; mov ES,pagetabl+[BX] ; load para addr of page holding list cell + mov BL,ES:[DI].cdr_page ; load link pointer (cdr field) + mov DI,ES:[DI].cdr + loop del_h_lp ; cdr through list for "n" elements +del_h_rt: ret ; return updated heap env ptr in BX,DI +delta_hp endp + + +;************************************************************************ +;* Local support - Obtain Frame Pointer for given lexical level * +;* * +;* Input Parameters: * +;* TIPC register CX - desired lexical level number * +;* 0=current lexical level, * +;* 1=lexical parent's level, etc. * +;* FP - current frame pointer * +;* BASE - current stack buffer base * +;* * +;* Output Parameters: * +;* TIPC register BX - frame pointer for desired level * +;* (absolute location in stack) * +;* ES:[SI] - pointer to desired stack frame * +;* (either in stack buffer, or in the heap) * +;* * +;* Notes: Register usage: * +;* AX - zeroed, so page numbers can be loaded into AL * +;* prior to copying to DI * +;* BX - frame pointer for current level * +;* CX - lexical level counter. decremented at each level * +;* DX - base offset of the stack segment currently being * +;* examined * +;* SI - stack segment's (continuation's) displacement * +;* DI - temporarily hold page number of next stack segment * +;************************************************************************ +delta_lv proc near + mov BX,FP ; load current frame pointer + mov DX,BASE ; and the stack buffer base + cmp CX,0 ; reference to current stack frame? + jg dlt_nt_0 ; if not, jump + +; current lexical level desired-- return active stack frame pointer + lea SI,S_stack+[BX] ; compute addr of current frame pointer + add BX,DX ; adjust for base of stack buffer + mov ES,[BP].C_ES ; load pointer to data segment + ret ; return BX, ES:[SI] to caller + +; find pointer to higher lexical level in stack buffer +dlt_loop: sub BX,DX ; adjust absolute frame ptr by base + jb dlt_in_h ; still in stack buffer? if not, jump +dlt_nt_0: mov BX,word ptr S_stack+[BX].sf_sdisp ; fetch static link + loop dlt_loop ; iterate until desired level found + +; pointer to desired level found in stack buffer + mov SI,BX ; copy absolute frame pointer + sub SI,DX ; adjust for current stack buffer base + jb dlt_nstk ; still within stack buffer? if not, jump + add SI,offset S_stack ; compute address of frame in stack buffer + mov ES,[BP].C_ES ; ES<-data segment + ret ; return BX, ES:[SI] + +; Frame pointer found, but frame's not in stack buffer +dlt_nstk: mov DI,PREV_pag ; load pointer to previous stack segment + mov SI,PREV_dis + LoadPage ES,DI +;;; mov ES,pagetabl+[DI] + mov DX,ES:[SI].con_base + xor AX,AX +dlt_nb: cmp BX,DX ; is frame within this segment? + jae dlt_here ; if so, jump + mov AL,ES:[SI].con_spag ; load pointer to its previous segment + mov DI,AX + mov SI,ES:[SI].con_sdis + LoadPage ES,DI +;;; mov ES,pagetabl+[DI] + mov DX,ES:[SI].con_base ; load stack segment's base offset + jmp dlt_nb ; search 'til segment containing frame found +dlt_here: mov AX,BX ; copy absolute frame pointer for level + sub AX,DX ; subtract this stack segment's base + add SI,AX ; add to continuation offset + add SI,offset con_data ; add fudge factor for continuation header + ret ; return BX, ES:[SI] to caller + +; Desired level not found, but current reference not in stack buffer +dlt_in_h: add BX,DX ; compute absolute location in stack + mov DI,PREV_pag ; load previous stack segment pointer + mov SI,PREV_dis + LoadPage ES,DI +;;; mov ES,pagetabl+[DI] + mov DX,ES:[SI].con_base + xor AX,AX +dlt_in_n: cmp BX,DX ; is frame in this stack segment? + jae dlt_fnd ; if so, jump + mov AL,ES:[SI].con_spag ; fetch pointer to next previous segment + mov DI,AX + mov SI,ES:[SI].con_sdis + LoadPage ES,DI +;;; mov ES,pagetabl+[DI] + mov DX,ES:[SI].con_base ; load this segment's base offset + jmp dlt_in_n ; keep searching stack segments +; Segment containing stack frame found-- fetch static link +dlt_fnd: sub BX,DX ; adjust frame displacement for seg base + mov BX,ES:[SI].con_data.sf_sdisp+[BX] ; load static link + loop dlt_in_n ; follow chain to desired lexical level + jmp dlt_nb ; found-- return pointer to stack frame + +delta_lv endp + + +;************************************************************************ +;* Local support - Expand "apply's" argument list into registers R1-Rn * +;* * +;* Purpose: To expand the argument list of an "apply" so that the * +;* operands are in the proper operand registers (R1-Rn) * +;* for a call to a closed procedure. * +;* * +;* Input Parameters: TIPC register AH - the number of the VM's * +;* general register which contains the pointer to * +;* the linked list of arguments. * +;* * +;* Output Parameters: TIPC register CX - a count of the arguments. * +;* * +;* Note: The "apply" operation expects two operands which are a * +;* function and a 'list' of arguments. In the event that * +;* the second argument is not a list, this routine simply * +;* substitutes that value as if it were an argument. This * +;* means that the "LIST" function is not actually needed * +;* for an argument list containing only one value. * +;* For example, the following are handled equivalently: * +;* * +;* "correct" code "not-correct" code * +;* (apply ftn (list 1)) (apply ftn 1) * +;* (apply ftn (list a b)) (apply ftn (cons a b)) * +;* * +;* Although this could be viewed as an optimization, in * +;* that it saves one list cell each time the argument list * +;* is created, the real reason it is done is to provide * +;* a fixup action when an error condition is detected. * +;************************************************************************ +aply_arg proc near +; Count the number of arguments to make sure there aren't too many + xor BX,BX ; copy the register number of the + mov BL,AH ; argument list to BX + mov SI,reg0_dis+[BX] ; load the argument list pointer + mov BX,reg0_pag+[BX] + xor CX,CX ; zero the argument counter +aply_lp1: cmp BL,0 ; is pointer nil? + je aply_ok ; if so, the last argument has been moved + inc CX ; increment the argument count + cmp CX,NUM_REGS-2 ; (can't use R0 or R63) + jg aply_err + cmp byte ptr ptype+[BX],LISTTYPE*2 ; pointer to a list cell? + jne aply_ok ; if not, assume last argument + LoadPage ES,BX +;;; mov ES,pagetabl+[BX] ; load para addr for list cell's page + mov BL,ES:[SI].cdr_page ; load the "cdr" pointer (next cell) + mov SI,ES:[SI].cdr + jmp aply_lp1 ; process 'til end of argument list + +; copy arguments into the registers +aply_ok: mov BL,AH ; copy arg list register back into BX + mov SI,reg0_dis+[BX] ; load the argument list pointer + mov BX,reg0_pag+[BX] + lea DI,reg1 ; load the address of VM register R1 + +aply_lp: cmp BL,0 ; is pointer nil? + je aply_don ; if so, the last argument has been moved + cmp byte ptr ptype+[BX],LISTTYPE*2 ; pointer to a list cell? + jne aply_huh ; if not, we've got a problem (jump) + LoadPage ES,BX +;;; mov ES,pagetabl+[BX] ; load para addr for list cell's page + mov AL,ES:[SI].car_page ; move the "car" portion of the list + mov byte ptr [DI].C_page,AL ; cell into the next available + mov AX,ES:[SI].car ; general register of the VM + mov [DI].C_disp,AX + mov BL,ES:[SI].cdr_page ; load the "cdr" pointer (next cell) + mov SI,ES:[SI].cdr + add DI,size C_ptr ; increment next register's address + jmp aply_lp ; process 'til end of argument list + +; If an element in the argument list is not a list cell, simply place +; that pointer into the next register. +aply_huh: mov [DI].C_page,BX + mov [DI].C_disp,SI + +aply_don: ret ; return to caller + +; ***Error-- too many arguments to expand into register*** +aply_err: restore ; reload the current location pointer and + sub SI,3 ; back it up to start of "apply" instruction + pushm ; push function name, offset + C_call disassem,,Load_ES ; call: disassemble("APPLY",offset); + pushm ; push arguments + C_call set_nume ; call: set_numeric_error(1,code,tmp_reg) + restore ; reload the location pointer + jmp sch_err ; Link to Scheme debugger +aply_arg endp + + +;************************************************************************ +; Lattice C callable routine to push a register onto Scheme's stack * +; Calling Sequence: C_push(reg) * +; where: int reg[2] - register (pointer/value) to push * +;************************************************************************ +C_args struc +C_BP dw ? ; Caller's BP + dw ? ; Return address +C_reg dw ? ; Pointer to register +C_args ends + + public C_push +C_push1 proc near +; Process overflow-- copy contents of stack to the heap +C_push2: push ES ; save ES across the call + call stk_ovfl ; copy the stack contents + pop ES ; restore ES + ; retry the push (fall through) +C_push: mov AX,TOS ; load the top of stack pointer + cmp AX,STKSIZE-PTRSIZE ; test for overflow + jge C_push2 ; jump, if overflow is going to occur + add AX,PTRSIZE ; decrement stop of stack pointer + mov TOS,AX ; and update it in memory + add AX,offset S_stack ; load the address of the new TOS + mov DI,AX ; copy TOS address into DI + pop DX ; unload the return address + pop BX ; load address of register to push + mov AL,byte ptr [BX].C_page ; load the page number, + mov [DI].car_page,AL ; pointer displacement, + mov AX,[BX].C_disp ; and move onto the top of + mov [DI].car,AX ; Scheme's stack + jmp DX ; return to caller +C_push1 endp + +;************************************************************************ +; Lattice C callable routine to pop a register from Scheme's stack * +; Calling Sequence: C_pop(reg) * +; where: int reg[2] - register to hold the value popped * +;************************************************************************ + public C_pop +C_pop proc near + mov AX,TOS ; load the top of stack pointer + sub AX,PTRSIZE ; increment stop of stack pointer + mov TOS,AX ; and update it in memory + add AX,offset S_stack+PTRSIZE ; load the address of the old TOS + mov SI,AX ; copy top of stack address into SI + pop DX ; unload the return address + pop BX ; fetch address of destination register + mov AL,[SI].car_page ; load page number, + mov byte ptr [BX].C_page,AL ; pointer displacement, + mov AX,[SI].car ; and update into + mov [BX].C_disp,AX ; receiving register + jmp DX ; return to caller +C_pop endp + +;************************************************************************ +;* Lattice C callable routine to force a Scheme VM call * +;* Calling Sequence: force_call(ret) * +;* where: int ret - the return address (relative to the * +;* current code block) * +;************************************************************************ +fc_args struc + dw ? ; caller's BP + dw ? ; return address +fc_ret dw ? ; Scheme return address +fc_args ends + + public force_ca +force_ca proc near + push BP ; save the caller's BP register + mov BP,SP ; establish local addressability + mov SI,[BP].fc_ret ; load the Scheme program return address + call new_SF ; create a new stack frame + mov FP,BX ; update the current frame pointer + pop BP ; restore the caller's BP + ret ; return to caller +force_ca endp + +prog ends + +PROGX segment byte public 'PROGX' + assume CS:XGROUP +bad_obj1: jmp bad_obj2 +load_ex label far + save ; save dest register, location pointer + cmp byte ptr ptype+[DI],LISTTYPE*2 ; is "code" pointer a list? + jne bad_obj1 ; if not, error (jump) + %LoadPage ES,DI +;;; mov ES,pagetabl+[DI] ; load pointer to "compiled program" + mov SI,reg0_dis+[BX] +; skip over "tag" portion of object program + mov BL,ES:[SI].cdr_page + mov SI,ES:[SI].cdr +; fetch the number of constants and multiply by three bytes/constant + cmp byte ptr ptype+[BX],LISTTYPE*2 ; is this a list cell? + jne bad_obj1 ; if not, error (jump) + %LoadPage ES,BX +;;; mov ES,pagetabl+[BX] + cmp ES:[SI].car_page,SPECFIX*2 ; is car's entry a fixnum? + jne bad_obj1 ; if not, error (jump) + mov AX,ES:[SI].car ; fetch immediate value of fixnum + shl AX,1 ; sign extend immediate value + sar AX,1 + inc AX ; add a constant for entry point address + mov DX,AX ; DX <- AX * 3 + shl AX,1 + add DX,AX + mov BL,ES:[SI].cdr_page ; follow cdr field of linked list + mov SI,ES:[SI].cdr +; fetch the number of code bytes + cmp byte ptr ptype+[BX],LISTTYPE*2 ; is this a list cell? + jne bad_obj1 ; if not, error (jump) + %LoadPage ES,BX +;;; mov ES,pagetabl+[BX] + cmp ES:[SI].car_page,SPECFIX*2 ; is car's entry a fixnum? + jne bad_obj1 ; if not, error (jump) + mov AX,ES:[SI].car ; fetch immediate value of fixnum + shl AX,1 ; sign extend immediate value + sar AX,1 +; compute number of bytes needed and allocate a new code block + add AX,DX ; add constants*3 + codebytes + mov BX,CODETYPE + pushm ; push arguments onto TIPC's stack + save ; preserve register DX across call + mov AX,DS ; make ES point to the data segment + mov ES,AX + call %allocbl ; allocate the code block + mov SP,BP ; drop arguments from stack +; load pointer to newly allocated code block + mov DI,tmp_page + %LoadPage ES,DI +;;; mov ES,pagetabl+[DI] +;;;; mov DX,ES ; save code block's paragraph address in DX + mov DX,DI ; save code block's page number in DX + mov DI,tmp_disp + add DI,PTRSIZE ; advance DI past block header +; store entry point address into code block + mov AL,SPECFIX*2 ; store tag=fixnum for entry point address + stosb + mov AX,[BP].save_DX ; store entry point address + add AX,PTRSIZE ; adjust entry point for block header + stosw +; reload pointer to object program [Note: garbage collection may have +; copied the linked list representation of the program, so pointers +; held in TIPC registers may not be valid.] + restore + mov SI,reg0_pag+[BX] ; load pointer to "object program" + %LoadPage ES,SI +;;; mov ES,pagetabl+[SI] + mov SI,reg0_dis+[BX] + mov BL,ES:[SI].cdr_page ; skip over "tag" + mov SI,ES:[SI].cdr + %LoadPage ES,BX +;;; mov ES,pagetabl+[BX] + mov CX,ES:[SI].car ; load number of constants + shl CX,1 ; sign extend immediate value + sar CX,1 + mov BL,ES:[SI].cdr_page ; skip over number of constants + mov SI,ES:[SI].cdr + %LoadPage ES,BX +;;; mov ES,pagetabl+[BX] + mov AX,ES:[SI].car ; load number of code bytes + shl AX,1 ; sign extend immediate value + sar AX,1 + mov BL,ES:[SI].cdr_page ; skip over number of codebytes + mov SI,ES:[SI].cdr + cmp byte ptr ptype+[BX],LISTTYPE*2 + je ok_obj + +; ***error-- invalid object format*** +bad_obj: jmp bad_obj2 + +ok_obj: %LoadPage ES,BX +;;; mov ES,pagetabl+[BX] + pushm ; save # codebytes, ptr to const's list cell + mov BL,ES:[SI].car_page ; load constant list header + mov SI,ES:[SI].car +;;;; mov ES,DX + %LoadPage0 ES,DX + cmp CX,0 ; zero length constants list? + je c_end ; if no constants, skip loop +c_loop: cmp BL,0 ; end of constants list? + je bad_obj ; if so, premature end of constant list + cmp byte ptr SS:ptype+[BX],LISTTYPE*2 ; is entry a list cell? + jne bad_obj ; if not, error (jump) + %LoadPage1 DS,BX +;;; mov DS,SS:pagetabl+[BX] ; fetch page's address + movsb ; copy car field to code block constants + movsw ; area + lodsb ; load cdr field to follow linked list + mov BL,AL + mov SI,[SI] + loop c_loop ; continue through constants list +; end of constants list-- process byte codes +c_end: + pop DS ; restore previously saved regs + pop SI + mov CX,BX ; tempsave current bx reg + pop BX ; bx = page number + %LoadPage ES,BX ; load segment register + mov BX,CX ; restore bx register + pop CX + + cmp BL,0 ; end of list found? + jne bad_obj ; if not, too many constants (jump) +; fetch pointer to codebyte list + mov BL,ES:[SI].cdr_page + mov SI,ES:[SI].cdr + cmp byte ptr ptype+[BX],LISTTYPE*2 ; is next entry a list cell? + jne bad_obj ; if not, error (jump) + %LoadPage ES,BX +;;; mov ES,pagetabl+[BX] + cmp ES:[SI].cdr_page,0 ; last entry in object program list? + je next$0 + jmp bad_obj ; if not, error (jump) +next$0: mov BL,ES:[SI].car_page ; load header to bytecode list + mov SI,ES:[SI].car + %LoadPage0 ES,DX ; Restore code block's paragraph address +;;; mov ES,DX + push DS +d_loop: cmp BL,0 ; end of constants list? + jne d_l$0 + jmp bad_obj ; if so, premature end of constant list +d_l$0: + cmp byte ptr SS:ptype+[BX],LISTTYPE*2 ; is entry a list cell? + je d_l$1 + jmp bad_obj ; if not, error (jump) +d_l$1: + %LoadPage1 DS,BX +;;; mov DS,SS:pagetabl+[BX] ; fetch page's address + lodsb ; load car's page number + cmp AL,SPECFIX*2 ; is codebyte entry a fixnum? + je d_lp_nxt ; Yes, continue + jmp bad_obj ; No, error +d_lp_nxt: + lodsw ; load immediate value + stosb ; store low order byte into code block + lodsb ; load cdr field to follow linked list + mov BL,AL + mov SI,[SI] + loop d_loop ; continue through codebyte list +; end of codebyte list-- move code block pointer to destination register + pop DS ; restore TIPC register DS + cmp BL,0 ; extraneous codebytes in list? + jne bad_obj3 ; if so, error (jump) + restore ; re-fetch dest reg, location pointer + mov AL,byte ptr tmp_page ; copy code block pointer into + mov byte ptr reg0_pag+[BX],AL ; destination register + mov AX,tmp_disp + mov reg0_dis+[BX],AX + jmp far ptr execute1 ; execute the code block +bad_obj3: jmp bad_obj +PROGX ends + + end + \ No newline at end of file diff --git a/sstring.asm b/sstring.asm new file mode 100644 index 0000000..1333e80 --- /dev/null +++ b/sstring.asm @@ -0,0 +1,518 @@ +; =====> SSTRING.ASM +;************************************************************************ +;* TIPC Scheme Runtime Support * +;* Interpreter -- String Operations * +;* * +;* (C) Copyright 1985 by Texas Instruments Incorporated. * +;* All rights reserved. * +;* * +;* Date Written: 18 January 1985 * +;* Last Modification: * +;* 4/27/88 (tc) - removed case conversion from characters in the range * +;* of 128 through 167 (see locases, hicases, collate). * +;* Our previous assumptions did not work for some inter-* +;* national character sets. * +;************************************************************************ + include scheme.equ + include sinterp.mac + + include sinterp.arg + +DGROUP group data +data segment word public 'DATA' + assume DS:DGROUP + +; Local data definitions +m_ch_eq db "CHAR=?",0 +m_ceq_ci db "CHAR-CI=?",0 +m_ch_lt db "CHAR","?" + + db "@","a","b","c","d","e","f","g" + db "h","i","j","k","l","m","n","o" + db "p","q","r","s","t","u","v","w" + db "x","y","z","[","\","]","^","_" + db "`","a","b","c","d","e","f","g" + db "h","i","j","k","l","m","n","o" + db "p","q","r","s","t","u","v","w" + db "x","y","z","{","|","}","~",127 + ; C .. ' ^ .. ` o c + ; ' u e a a a a ' + db 128,129,130,131,132,133,134,135 ;135,129,130,131,132,133,134,135 + ; ^ .. ` .. ^ ` .. o + ; e e e i i i A A + db 136,137,138,139,140,141,142,143 ;136,137,138,139,140,141,132,134 + ; ' ^ .. ` ^ ` + ; E ae AE o o o u u + db 144,145,146,147,148,149,150,151 ;130,145,145,147,148,149,150,151 + ; .. .. .. + ; y O U (currency symbols) + db 152,153,154,155,156,157,158,159 ;152,148,129,155,156,157,158,159 + ; ' ' ' ' ~ ~ + ; a i o u n N + db 160,161,162,163,164,165,166,167 ;160,161,162,163,164,164,166,167 + db 168,169,170,171,172,173,174,175 + db 176,177,178,179,180,181,182,183 + db 184,185,186,187,188,189,190,191 + + db 192,193,194,195,196,197,198,199 + db 200,201,202,203,204,205,206,207 + db 208,209,210,211,212,213,214,215 + db 216,217,218,219,220,221,222,223 +; beta + db 224,225,226,227,228,229,230,231 + db 232,233,234,235,236,237,238,239 + db 240,241,242,243,244,245,246,247 + db 248,249,250,251,252,253,254,255 + +hicases db 000,001,002,003,004,005,006,007 + db 008,009,010,011,012,013,014,015 + db 016,017,018,019,020,021,022,023 + db 024,025,026,027,028,029,030,031 + db " ","!",'"',"#","$","%","&","'" + db "(",")","*","+",",","-",".","/" + db "0","1","2","3","4","5","6","7" + db "8","9",":",";","<","=",">","?" + + db "@","A","B","C","D","E","F","G" + db "H","I","J","K","L","M","N","O" + db "P","Q","R","S","T","U","V","W" + db "X","Y","Z","[","\","]","^","_" + db "`","A","B","C","D","E","F","G" + db "H","I","J","K","L","M","N","O" + db "P","Q","R","S","T","U","V","W" + db "X","Y","Z","{","|","}","~",127 + ; C .. ' ^ .. ` o c + ; ' u e a a a a ' + db 128,129,130,131,132,133,134,135 ;128,154,144,"A",142,"A",143,128 + ; ^ .. ` .. ^ ` .. o + ; e e e i i i A A + db 136,137,138,139,140,141,142,143 ;"E","E","E","I","I","I",142,143 + ; ' ^ .. ` ^ ` + ; E ae AE o o o u u + db 144,145,146,147,148,149,150,151 ;144,146,146,"O",153,"O","U","U" + ;.. .. .. + ; y O U (currency symbols) + db 152,153,154,155,156,157,158,159 ;"Y",153,154,155,156,157,158,159 + ; ' ' ' ' ~ ~ + ; a i o u n N + db 160,161,162,163,164,165,166,167 ;"A","I","O","U",165,165,166,167 + db 168,169,170,171,172,173,174,175 + db 176,177,178,179,180,181,182,183 + db 184,185,186,187,188,189,190,191 + + db 192,193,194,195,196,197,198,199 + db 200,201,202,203,204,205,206,207 + db 208,209,210,211,212,213,214,215 + db 216,217,218,219,220,221,222,223 +; beta + db 224,225,226,227,228,229,230,231 + db 232,233,234,235,236,237,238,239 + db 240,241,242,243,244,245,246,247 + db 248,249,250,251,252,253,254,255 + +collate db 000,001,002,003,004,005,006,007 + db 008,009,010,011,012,013,014,015 + db 016,017,018,019,020,021,022,023 + db 024,025,026,027,028,029,030,031 + db " ","!",'"',"#","$","%","&","'" + db "(",")","*","+",",","-",".","/" + db "0","1","2","3","4","5","6","7" + db "8","9",":",";","<","=",">","?" + + db "@","A","B","C","D","E","F","G" + db "H","I","J","K","L","M","N","O" + db "P","Q","R","S","T","U","V","W" + db "X","Y","Z","[","\","]","^","_" + db "`","a","b","c","d","e","f","g" + db "h","i","j","k","l","m","n","o" + db "p","q","r","s","t","u","v","w" + db "x","y","z","{","|","}","~",127 + ; C .. ' ^ .. ` o c + ; ' u e a a a a ' + db 128,129,130,131,132,133,134,135 ;"C","u","e","a","a","a","a","c" + ; ^ .. ` .. ^ ` .. o + ; e e e i i i A A + db 136,137,138,139,140,141,142,143 ;"e","e","e","i","i","i","A","A" + ; ' ^ .. ` ^ ` + ; E ae AE o o o u u + db 144,145,146,147,148,149,150,151 ;"E","a","A","o","o","o","u","u" + ; .. .. .. + ;y O U (currency symbols) + db 152,153,154,155,156,157,158,159 ;"y","O","U","$","$","$","$","$" + ; ' ' ' ' ~ ~ + ; a i o u n N + db 160,161,162,163,164,165,166,177 ;"a","i","o","u","n","N",166,167 + db 168,169,170,171,172,173,174,175 ;"?",169,170,171,172,"!",'"','"' + db 176,177,178,179,180,181,182,183 + db 184,185,186,187,188,189,190,191 + + db 192,193,194,195,196,197,198,199 + db 200,201,202,203,204,205,206,207 + db 208,209,210,211,212,213,214,215 + db 216,217,218,219,220,221,222,223 +; beta + db 224,"s",226,227,228,229,230,231 + db 232,233,234,235,236,237,238,239 + db 240,241,242,243,244,245,246,247 + db 248,249,250,251,252,253,254,255 + +data ends + + +PGROUP group prog +prog segment byte public 'PROG' + assume CS:PGROUP + +str_int 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 ; mov SP,BP before next_PC + extrn src_err:near ; Source (operand) error print routine + extrn sch_err:near ; link to Scheme debugger + +char_cmp macro comparison,case,operation + local w,x,y,z + lods word ptr ES:[SI] ; load operands + xor BX,BX + mov BL,AL ; copy the destination=source1 register + mov DI,BX ; number, copy into DI, and compute + add DI,offset reg0 ; the register's address + mov BL,AH ; copy the source2 register number + mov AL,byte ptr reg0_pag+[BX] ; load tag of src2 operand + cmp AL,SPECCHAR*2 ; is source2 a character? + jne z ; if not, error (jump) + cmp AL,byte ptr [DI].C_page ; is source1 a character? + jne z ; if not, error (jump) +IFIDN , + mov AL,byte ptr reg0_dis+[BX] ; move character value of source2 + mov BX,offset locases ; Fetch lower-case equivalents + xlat + mov AH,AL ; Save equivalent in AH + mov AL,byte ptr[DI].C_disp ; move char value of source1 + xlat ; Fetch lower-case eqivalent +ELSE + mov AL,byte ptr [DI].C_disp ; Fetch characters + mov AH,byte ptr reg0_dis+[BX] +ENDIF + mov BX,offset collate ; Get collation values of chars + xlat + xchg AL,AH + xlat + cmp AH,AL ; Compare + j&comparison y ; jump, if test is satisfied + xor AX,AX ; place 'nil in destination + mov byte ptr [DI].C_page,AL ; register + mov [DI].C_disp,AX + jmp next ; return to interpreter +y: mov byte ptr [DI].C_page,T_PAGE*2 ; place 't in + mov [DI].C_disp,T_DISP ; destination register + jmp next ; return to interpreter +; ***error-- one (or both) operands aren't characters*** +z: mov AX,offset operation +IFIDN , +error_2: add BX,offset reg0 ; compute address of source 2 + pushm ; push source 2, source 1, operation name + C_call set_src_,,Load_ES ; call: set_source_error + jmp sch_err ; link to Scheme debugger +ELSE + jmp error_2 +ENDIF + endm + + +;************************************************************************ +;* AL AH * +;* (char-= char1 char2) char-= dest,src * +;* * +;* Purpose: Scheme interpreter support for comparing the equality of * +;* character data objects. * +;* * +;* Description: The tags (page numbers) or the objects are compared * +;* for equality. If they are not equal, at least one of * +;* the operands is not a character, and an error is * +;* signaled. If they are equal, a second check to make * +;* sure both are characters is performed. * +;* * +;* After validating the tag fields, the displacement fields* +;* are compared for equality. If they are identical, the * +;* characters are equal and 't is returned in the destina- * +;* tion register. If not equal, 'nil is returned in the * +;* destination register. * +;************************************************************************ + public ch_eq_p +ch_eq_p: char_cmp e,CS,m_ch_eq + +;************************************************************************ +;* AL AH * +;* (char-equal? char1 char2) char-eq? dest,src * +;* * +;* Purpose: Scheme interpreter support for comparing the equality of * +;* character data objects ignoring case. * +;* * +;* Description: The tags (page numbers) or the objects are compared * +;* for equality. If they are not equal, at least one of * +;* the operands is not a character, and an error is * +;* signaled. If they are equal, a second check to make * +;* sure both are characters is performed. * +;* * +;* The displacements of both operands are loaded and * +;* mapped to uppercase. They are then compared for * +;* equality. If equal, 't is returned in the destination * +;* registers. Otherwise, 'nil is returned. * +;************************************************************************ + public ch_eq_ci +ch_eq_ci: char_cmp e,CI,m_ceq_ci + +;************************************************************************ +;* AL AH * +;* (char-, + mov BX,offset hicases +ELSE +IFIDN , + mov BX,offset locases +ELSE + ***error*** Invalid: direction +ENDIF +ENDIF + xlat ; Fetch alternate case + mov byte ptr [DI].C_disp,AL ; and store into dest register + jmp next +; ***error-- invalid source operand*** +y: mov AX,offset name ; load the instruction's name text +IFIDN , +error_1: pushm ; push operand, operand count, instr. name + C_call set_src_,,Load_ES ; call set_source_error + jmp sch_err ; link to Scheme debugger +ELSE + jmp error_1 ; jump to error routine +ENDIF + endm + +;************************************************************************ +;* AL * +;* (char-upcase char) char-upcase dest * +;* * +;* Purpose: Scheme interpreter support for conversion of characters * +;* to uppercase * +;************************************************************************ + public ch_up +ch_up: ch_case UP,m_ch_up + +;************************************************************************ +;* AL * +;* (char-downcase char) char-downcase dest * +;* * +;* Purpose: Scheme interpreter support for conversion of characters * +;* to lowercase * +;************************************************************************ + public ch_down +ch_down: ch_case DOWN,m_ch_dwn + + purge ch_case + +;************************************************************************ +;* AL AH * +;* (make-string len init) make-string len,init* +;************************************************************************ + public make_str +make_str: lods word ptr ES:[SI] ; load the operands of the instruction + save ; save the operands and location pointer + xor BX,BX + mov BL,AL ; copy the destination register number + add BX,offset reg0 ; into BX and compute its address + cmp byte ptr [BX].C_page,SPECFIX*2 ; is length a fixnum? + jne mk_st_er ; if not, error (jump) + mov AX,[BX].C_disp ; load the immediate value for the size + shl AX,1 ; and sign extend it + sar AX,1 + jl mk_st_er ; if size is negative, error + mov CX,STRTYPE ; load the tag value for the string object + pushm ; push arguments to "alloc_block" + C_call alloc_bl,,Load_ES ; call: alloc_block(reg, STRTYPE, len) + pop BX ; restore destination register address + mov DI,[BX].C_disp ; load a pointer to the newly allocated + mov BX,[BX].C_page ; string object + LoadPage ES,BX +;;; mov ES,pagetabl+[BX] + restore ; reload operands to instruction + mov BL,AH ; copy initial value register number + mov AL,byte ptr reg0_pag+[BX] ; load page number of init value + cmp AL,SPECCHAR*2 ; init value a character? + je st_fl_3 ; if a character, jump + cmp AL,NIL_PAGE*2 ; use default value? (nil?) + jne mk_st_er ; if not nil, error (jump) + mov AL," " ; load default string fill character + jmp short st_fl_4 +mk_st_er: lea BX,m_mk_str ; load address of "make-string" text + jmp src_err ; display "source operand error" message + +;************************************************************************ +;* AL AH * +;* (string-fill! string char) string-fill! str,char * +;************************************************************************ + public str_fill +str_fill: lods word ptr ES:[SI] ; load string-fill operands + save ; save current location pointer + xor BX,BX + mov BL,AL ; copy string register number + mov DI,BX + mov BL,byte ptr reg0_pag+[DI] + cmp byte ptr ptype+[BX],STRTYPE*2 ; is 1st operand a string? + jne st_fl_er ; if not, error (jump) + LoadPage ES,BX +;;; mov ES,pagetabl+[BX] ; load a pointer to the string object + mov DI,reg0_dis+[DI] + mov BL,AH ; copy initialization value register number + cmp reg0_pag+[BX],SPECCHAR*2 ; is it a char? + jne st_fl_er ; if not, error +st_fl_3: mov AL,byte ptr reg0_dis+[BX] ; load initialization character +st_fl_4: mov CX,ES:[DI].str_len ; load length of string object + cmp CX,0 ;;; check for small string + jge st_010 + add CX,BLK_OVHD+PTRSIZE ;;; adjust for small string +st_010: sub CX,offset str_data ; compute number of characters + add DI,offset str_data ; advance index to 1st character position +rep stosb ; fill string object with init character + jmp next_SP ; return to interpreter +st_fl_er: lea BX,m_st_fl ; load address of "fill-string" text + jmp src_err ; display "source operand error" message + +str_int endp + +;************************************************************************ +;* Macro Support for String ref/set * +;************************************************************************ +st_thing macro ref_or_set,message + local w,x,y,z + lods word ptr ES:[SI] ; load string pointer and index regs + xor BX,BX + mov BL,AL ; copy string/dest reg number into DI + mov DI,BX +IFIDN , + lods byte ptr ES:[SI] ; load source operand register number + mov DL,AL ; and save it in TIPC register DL +ENDIF + save ; save the location pointer + mov BL,byte ptr reg0_pag+[DI] ; load string page number + cmp byte ptr ptype+[BX],STRTYPE*2 ; is it a string? + jne y ; if not a string, error (jump) + LoadPage ES,BX +;;; mov ES,pagetabl+[BX] + mov BL,AH ; copy index register number + cmp byte ptr reg0_pag+[BX],SPECFIX*2 ; is index a fixnum? + jne y ; if not a fixnum, error (jump) + mov AX,reg0_dis+[BX] ; load immediate value and + shl AX,1 ; sign extend to 16 bits + sar AX,1 + jl z ; if index negative, error (jump) + add AX,offset str_data ; advance pointer past string header + mov SI,reg0_dis+[DI] ; load pointer to string object + mov CX,ES:[SI].str_len ; compare index with string length + cmp CX,0 ;;; check for small string + jge w + add CX,BLK_OVHD+PTRSIZE ;;; adjust for small string +w: cmp AX,CX + jge z ; if index too large, error (jump) + add SI,AX ; add index to string pointer +IFIDN , + mov byte ptr reg0_pag+[DI],SPECCHAR*2 ; set tag=character + mov BL,ES:[SI] ; fetch desired character + mov reg0_dis+[DI],BX ; and store into destination register +ELSE +IFIDN , + mov BL,DL ; copy source value register number + cmp byte ptr reg0_pag+[BX],SPECCHAR*2 ; is source a character? + jne y ; if not a character, error (jump) + mov AL,byte ptr reg0_dis+[BX] ; store source character into + mov ES:[SI],AL ; string at desired offset +ELSE + ***error*** Invalid: ref_or_set +ENDIF +ENDIF + jmp next_PC ; return to interpreter +; ***error-- invalid source operand*** +y: lea BX,message ; load address of operation name text + jmp src_err ; display "source operand error" message +; ***error-- invalid string offset*** +z: mov BX,offset message ; load address of instruction name +IFIDN , + mov DX,3 ; STRING-REF is 3 bytes long +s_out_bn: restore ; load location pointer and + sub SI,DX ; back up to start of instruction in error + pushm ; push instruction's offset, name + C_call disassem,,Load_ES ; disassemble instruction for *irritant* + pushm ; push args to "set_numeric_error" + C_call set_nume ; set_numeric_error(1,ST_OFF_ERR,tmp_reg); + restore ; load offset of next instruction + jmp sch_err ; Link to Scheme debugger +ELSE + mov DX,4 ; STRING-SET! is 4 bytes long + jmp s_out_bn ; continue error processing +ENDIF + endm + +;************************************************************************ +;* AL AH * +;* (string-ref string index) string-ref str,index * +;************************************************************************ + public st_ref +st_ref: st_thing REF,m_st_ref + +;************************************************************************ +;* AL AH AL * +;* (string-set! string index char) string-set! str,index,char * +;************************************************************************ + public st_set +st_set: st_thing SET,m_st_set + + purge st_thing + +prog ends + end + \ No newline at end of file diff --git a/stackf.equ b/stackf.equ new file mode 100644 index 0000000..1293e1f --- /dev/null +++ b/stackf.equ @@ -0,0 +1,55 @@ +; =====> STACKF.EQU +; Copyright 1984,1985 by Texas Instruments Incorporated. +; All Rights Reserved. +; +; Last Modification: 4 August 1985 + +; Stack Frame +; +; +------------------+ +; Stack base -> | stack for prev | +; : dynamic levels : +; |------------------| +; Frame pointer ->| code base -> | \ +; |------------------| | return address +; | return addr disp | / +; |------------------| +; | dynamic link | caller's FP +; |------------------| +; | environment | current environment +; |------------------| +; | static link | lexical parent's FP +; |------------------| +; | closure ptr | pointer to routine's closure object +; |------------------| (or nil, if an open call) +; | local | +; : variable : +; top of stack -> | allocation | +; +------------------+ +sf_def struc + +sf_cb_pag db ? ; code base pointer page number +sf_cb_dis dw ? ; code base pointer displacement + +sf_rtag db SPECFIX*2 ; return address tag=fixnum +sf_ret dw ? ; return address displacement + +sf_dtag db SPECFIX*2 ; dynamic link tag=fixnum +sf_ddisp dw ? ; dynamic link displacement + +sf_hpage db ? ; heap environment page number +sf_hdisp dw ? ; heap environment displacement + +sf_stag db SPECFIX*2 ; lex parent's static link tag=fixnum +sf_sdisp dw ? ; lex parent's static link displacement + +sf_cl_pg db ? ; closure pointer page number +sf_cl_ds dw ? ; closure pointer page number + +; start of local variable allocation area +sf_dat_p db ? ; local variable's page number +sf_dat_d dw ? ; local variable's displacement + +sf_def ends +SF_OVHD equ sf_dat_p-sf_cb_pag ; size of stack frame header + \ No newline at end of file diff --git a/stdio.h b/stdio.h new file mode 100644 index 0000000..0697e2f --- /dev/null +++ b/stdio.h @@ -0,0 +1,173 @@ +/** +* +* This header file defines the information used by the standard I/O +* package. +* +**/ +#define _BUFSIZ 512 /* standard buffer size */ +#define BUFSIZ 512 /* standard buffer size */ +#define _NFILE 20 /* maximum number of files */ + +struct _iobuf +{ +unsigned char *_ptr; /* current buffer pointer */ +int _rcnt; /* current byte count for reading */ +int _wcnt; /* current byte count for writing */ +unsigned char *_base; /* base address of I/O buffer */ +int _size; /* size of buffer */ +int _flag; /* control flags */ +unsigned char _file; /* file number */ +unsigned char _cbuff; /* single char buffer */ +}; + +extern struct _iobuf _iob[_NFILE]; + +/** +* +* Definitions associated with _iobuf._flag +* +*/ +#define _IOFBF 0 /* fully buffered (for setvbuf) */ +#define _IOREAD 1 /* read flag */ +#define _IOWRT 2 /* write flag */ +#define _IONBF 4 /* non-buffered flag */ +#define _IOMYBUF 8 /* private buffer flag */ +#define _IOEOF 16 /* end-of-file flag */ +#define _IOERR 32 /* error flag */ +#define _IOLBF 64 /* line-buffered flag */ +#define _IORW 128 /* read-write (update) flag */ +#define _IOAPP 0x4000 /* append flag */ +#define _IOXLAT 0x8000 /* translation flag */ + +#ifndef NULL +#if SPTR +#define NULL 0 /* null pointer value */ +#else +#define NULL 0L +#endif +#endif +#define FILE struct _iobuf /* shorthand */ +#define EOF (-1) /* end-of-file code */ + + +#define stdin (&_iob[0]) /* standard input file pointer */ +#define stdout (&_iob[1]) /* standard output file pointer */ +#define stderr (&_iob[2]) /* standard error file pointer */ +#define stdaux (&_iob[3]) /* standard auxiliary file pointer */ +#define stdprt (&_iob[4]) /* standard printer file pointer */ + + +#define getc(p) (--(p)->_rcnt>=0? *(p)->_ptr++:_filbf(p)) +#define getchar() getc(stdin) +#define putc(c,p) (--(p)->_wcnt>=0? ((int)(*(p)->_ptr++=(c))):_flsbf((c),p)) +#define putchar(c) putc(c,stdout) +#define feof(p) (((p)->_flag&_IOEOF)!=0) +#define ferror(p) (((p)->_flag&_IOERR)!=0) +#define fileno(p) (p)->_file +#define rewind(fp) fseek(fp,0L,0) +#define fflush(fp) _flsbf(-1,fp) +#define clearerr(fp) clrerr(fp) + +#ifndef NARGS +extern void clrerr(FILE *); +extern int cprintf(char *, ); +extern int cscanf(char *, ); +extern int fclose(FILE *); +extern int fcloseall(void); +extern FILE *fdopen(int, char *); +extern int fgetc(FILE *); +extern int fgetchar(void); +extern char *fgets(char *, int, FILE *); +extern int flushall(void); +extern int fmode(FILE *, int); +extern FILE *fopen(char *, char *); +extern FILE *fopene(char *, char *, char *); +extern int fprintf(FILE *, char *, ); +extern int fputc(int, FILE *); +extern int fputchar(int); +extern int fputs(char *, FILE *); +extern int fread(char *, int, int, FILE *); +extern FILE *freopen(char *, char *, FILE *); +extern int fscanf(FILE*, char *, ); +extern int fseek(FILE *, long, int); +extern long ftell(FILE *); +extern int fwrite(char *, int, int, FILE *); +extern char *gets(char *); +extern int printf(char *, ); +extern int puts(char *); +extern scanf(char *, ); +extern int setbuf(FILE *, char *); +extern int setnbf(FILE *); +extern int setvbuf(FILE*, char *, int, int); +extern int sprintf(char *, char *, ); +extern sscanf(char *, char *, ); +extern int ungetc(int, FILE *); +extern int _filbf(FILE *); +extern int _flsbf(int, FILE *); + +#else +extern void clrerr(); +extern int cprintf(); +extern int cscanf(); +extern int fclose(); +extern int fcloseall(); +extern FILE *fdopen(); +extern int fgetc(); +extern int fgetchar(); +extern char *fgets(); +extern int flushall(); +extern int fmode(); +extern FILE *fopen(); +extern FILE *fopene(); +extern int fprintf(); +extern int fputc(); +extern int fputchar(); +extern int fputs(); +extern int fread(); +extern FILE *freopen(); +extern int fscanf(); +extern int fseek(); +extern long ftell(); +extern int fwrite(); +extern char *gets(); +extern int printf(); +extern int puts(); +extern scanf(); +extern int setbuf(); +extern int setnbf(); +extern int setvbuf(); +extern int sprintf(); +extern sscanf(); +extern int ungetc(); +extern int _filbf(); +extern int _flsbf(); +#endif + +/** +* +* Miscellaneous I/O services +* +*/ +#ifndef NARGS +extern int access(char *, int); +extern int chdir(char *); +extern int chmod(char *, int); +extern char *getcwd(char *, int); +extern int mkdir(char *); +extern int perror(char *); +extern int rename(char *, char *); +extern int rmdir(char *); +extern char *tmpnam(char *); +#else +extern int access(); +extern int chdir(); +extern int chmod(); +extern char *getcwd(); +extern int mkdir(); +extern int perror(); +extern int rename(); +extern int rmdir(); +extern char *tmpnam(); +#endif + + diff --git a/stimer.asm b/stimer.asm new file mode 100644 index 0000000..8b0a204 --- /dev/null +++ b/stimer.asm @@ -0,0 +1,118 @@ +; =====> STIMER.ASM +;*************************************** +;* TIPC Scheme '84 Engine Timer * +;* Utilities * +;* * +;* (C) Copyright 1984,1985 by Texas * +;* Instruments Incorporated. * +;* All rights reserved. * +;* * +;* Date Written: June 1985 * +;* Last Modification: 30 July 1985 * +;*************************************** + include scheme.equ + +DGROUP group data +data segment word public 'DATA' + assume DS:DGROUP +timer_int db 58h ;40 Hz timer interrupt number +data ends + +PGROUP group prog +prog segment byte public 'PROG' + assume CS:PGROUP + +dos_func equ 21h ;DOS function call interrupt number +get_vec equ 35h ;DOS call to retrieve interrupt vector +set_vec equ 25h ;Call to set vector + + public tickstat +tickstat db -1 ;0=timeout, 1=engine running, + ; -1=no engine running (normal) +clk_ptr dw 0,0 ;Former timer vector +lo_time dw 0 ;Timer ticks +hi_time dw 0 + +; Start timer running +; Calling sequence: set_timer(hi,lo) +; Where ---- hi,lo: upper,lower words of initial timer value +; Returns nonzero iff the set was during normal VM running mode +set_args struc + dw ? ;Caller's BP + dw ? ;Return address +hi dw ? ;High word +lo dw ? ;Low word +set_args ends + public settimer +settimer proc near + cmp PC_MAKE,252 ;Is computer an IBM variant? + jb nochange ;Jump if not + mov timer_int,1ch ;Otherwise, set to IBM's vector +nochange: xor AX,AX ;Clear AX + cmp CS:tickstat,-1 ;Check for normal run mode + jne no_set ;Abort if timeout or engine running + push BP + mov BP,SP + push ES ;Save ES + mov AH,get_vec ;Put present timer interrupt vector + mov AL,timer_int ; into ES:BX + int dos_func + mov CS:clk_ptr,BX ;Save vector + mov CS:clk_ptr+2,ES + pop ES ;Restore ES + mov AX,[BP].hi ;Set timer + mov CS:hi_time,AX + mov AX,[BP].lo + mov CS:lo_time,AX + push DS ;Save DS + mov AH,set_vec ;Set new interrupt vector + mov AL,timer_int + push CS ;Put vector segment number in DS + pop DS + mov DX,offset tick ;Vector offset in DX + int dos_func + pop DS ;Restore DS + mov AL,1 ;Denote engine running + mov CS:tickstat,AL + pop BP ;Restore BP +no_set: ret +settimer endp + +; Stop the timer +; Calling sequence: rst_timer(); +; Returns the number in the counter at the time of reset + public rsttimer +rsttimer proc near + cmp CS:tickstat,1 ;Only if timeout or engine running + ja no_reset ;Otherwise forget it + mov AH,set_vec ;Prepare to reset timer interrupt + mov AL,timer_int + push DS ;Save DS + lds DX,dword ptr CS:clk_ptr ;Put original vector into DS:DX + int dos_func + pop DS ;Restore DS + mov CS:tickstat,-1 ;Denote normal mode +no_reset: mov AX,CS:hi_time ;Return 32-bit clock value + mov BX,CS:lo_time + ret +rsttimer endp + +;The new timer code +tick proc near + sti ;Re-enable interrupts + cmp CS:tickstat,0 ;If timeout, do nothing special + je norm_vec + sub CS:lo_time,1 ;Otherwise decrement counter + sbb CS:hi_time,0 + jnz norm_vec ;If not zero, jump ahead + cmp CS:lo_time,0 + jnz norm_vec + mov CS:tickstat,0 ;Otherwise, record timeout event + C_call force_ti ;Force a timeout condition +norm_vec: jmp dword ptr CS:clk_ptr ;Jump to original timer code +tick endp + +prog ends + end + + \ No newline at end of file diff --git a/strmlnrs.asm b/strmlnrs.asm new file mode 100644 index 0000000..ae5e1b3 --- /dev/null +++ b/strmlnrs.asm @@ -0,0 +1,679 @@ +; =====> STIMER.ASM +;*************************************** +;* TIPC Scheme '84 Things That Could * +;* Have Been Done in C but Why Waste * +;* Execution Time and Codespace? * +;* * +;* (C) Copyright 1984,1985 by Texas * +;* Instruments Incorporated. * +;* All rights reserved. * +;* * +;* Date Written: July 1985 * +;* Last Modification: 8 October 1985 * +;*************************************** + include scheme.equ + +DGROUP group data +data segment word public 'DATA' + assume DS:DGROUP +;Table of strange characters +stranges db " ,'" + db ';":()`' + db 13,12,11,10,9,0 + +;Random number registers +krala dw 22425 +kralb dw 30029 ;RANDOMIZE puts seed value here +;Random number table +kraltbl dw 4053,32361,7773,17385,11177,20413,27513,16501 + dw 5953,17673,20725,12247,28429,30861,16849,22375 +;Copy of random number registers and table. +krala1 dw 22425 +kralb2 dw 30029 +kraltbl1 dw 4053,32361,7773,17385,11177,20413,27513,16501 + dw 5953,17673,20725,12247,28429,30861,16849,22375 +kral_len equ krala1-krala + +data ends + +PGROUP group prog +prog segment byte public 'PROG' + assume CS:PGROUP + +;For space and performance reasons, some procedures have been written in the +; following style: the arguments are popped off the stack, and the +; procedure may end in an indirect JMP instead of a RET. In this source file, +; the following are such procedures: +; toblock, gvchars, blk2pbuf, putlong, thefix, ldlong, msubstr, +; mcmpstr, ldreg, pt_flds4, pt_flds6, str2str, adj4bord + +; Convert flonum to bignum +; Calling sequence: flotobig(flo,bigbuf) +; Where ---- flo: double-length flonum such that abs(flo)>=1 +; bigbuf: pointer to buffer for bignum formation +fbargs struc + dw ? ;Return address +flo dw ?,?,?,? ;Flonum +bigbuf dw ? ;Pointer to bignum buffer +fbargs ends + public flotobig +flotobig proc near + mov BX,SP + lea SI,[BX].flo ;Fetch pointer to flonum + mov DI,[BX].bigbuf ;Fetch buffer pointer + inc DI ;Point DI to sign byte + inc DI + cld ;Direction forward + mov AX,[BX+6].flo ;Fetch exponent word to CX + mov CX,AX + and AX,0fh ;Save mantissa part back + or AL,10h + mov [BX+6].flo,AX + mov AL,AH ;Zero AL + test CH,80h ;Negative flonum? + jz ftb1 ;Jump if not + inc AL ;Otherwise, set AL to 1 +ftb1: stosb ;Store sign byte + mov BX,DI ;Save address of first word in BX + mov AL,AH ;Zero AL again + and CX,7ff0h ;Discard sign byte and mantissa + sub CX,3ff0h ;Remove exponent bias + shl CX,1 +;At this stage, CH+1==number of bytes for bignum, CL shows how much to +; shift mantissa left (once per 20h) + mov DX,CX ;Use DX to count the shifts + xor DH,DH ;Set up shift count + add DX,80h ;Account for placing leading 1 in high byte +ftb2: shl word ptr[SI],1 ;Shift mantissa left + rcl word ptr[SI+2],1 + rcl word ptr[SI+4],1 + rcl word ptr[SI+6],1 + sub DX,20h ;Repeat until done + jnz ftb2 + mov CL,CH ;Set CX to number of bignum bytes + xor CH,CH + inc CX + sub CX,8 ;Check for leading zeros + js ftb3 ;Jump if not all the mantissa will be done + jz ftb3 ;Jump if no trailing zeros exist + rep stosb ;Else store as many zeros as necessary +ftb3: sub SI,CX ;Point SI to eligible part of mantissa + add CX,8 ;Set mantissa byte count + rep movsb ;Copy flonum mantissa to bignum + mov CX,DI ;Find number of bytes in bignum proper + sub CX,BX + shr CX,1 ;Find number of words + jnc ftb4 ;If a whole number of words, do nothing + mov byte ptr[DI],0 ;Otherwise, pad with a 0 + inc CX ;Adjust word count +ftb4: mov [BX-3],CX ;Save size of bignum + ret +flotobig endp + +; Find the size of a flonum +; Calling sequence: flosiz(flo); +; Where ---- flo: double-length flonum +; Returns the number of bytes needed for a working flonum formed from +; trunc(flonum) +fsargs struc + dw ? ;Return address +fl dw ?,?,?,? ;Double-length flonum +fsargs ends + public flosiz +flosiz proc near + mov SI,SP + mov AX,[SI+6].fl ;Fetch word containing exponent + and AX,7ff0h ;Drop sign and mantissa + sub AX,3ff0h ;Is abs(flo) < 1? + jc small ;Jump if small + mov AL,AH ;Otherwise, return number of bytes + xor AH,AH + shl AL,1 + add AL,5 + ret +small: xor AX,AX ;Return 0 for smallness + ret +flosiz endp + +; Move bytes from buffer to allocated Scheme block +; Calling sequence: toblock(reg,offs,buf,q) +; Where ---- reg: Scheme register pointing to block +; offs: Offset into block to begin transfer +; buf: Buffer pointer +; q: Number of bytes to move +;Stack elements in order of popping: +; Return address, register, offset, buffer address, number of bytes + public toblock +toblock proc near + pop DX ;Save return address in DX + pop BX ;Get register address + mov DI,[BX].C_disp ;Put 8088 address in ES:DI + mov BX,[BX].C_page + mov AX,ES + LoadPage ES,BX +;;; mov ES,pagetabl+[BX] + pop CX ;Get offset + add DI,CX ;Add to DI + pop SI ;Get source address (buffer ptr) + pop CX ;Get number of bytes + jcxz tbskip ;If no bytes, don't move + cld ;Direction forward + rep movsb ;Move bytes +tbskip: mov ES,AX ;Restore ES + jmp DX ;Return +toblock endp + +IFNDEF PROMEM +; Give characters from a C string +; Calling sequence: gvchars(str,len) +; Where ---- str: C string address +; len: Number of characters to give +;Stack elements in order of popping: +; Return address, string address, number of chars + extrn givechar:near + public gvchars +gvchars proc near + pop DI ;Get return address + pop SI ;Get string address + pop CX ;Get number of chars + push DI ;Put return address back + jcxz given ;If no chars, stop + cld ;Direction forward +gvlp: push CX ;Save count + lodsb ;Fetch string character + push SI ;Save pointer to next char + push AX + call givechar ;Give it + inc SP ;Restore stack + inc SP + pop SI ;Restore address and count + pop CX + loop gvlp ;Give 'til done +given: ret ;Return +gvchars endp + +; Move characters from block (symbol or string) to print buffer +; Calling sequence: blk2pbuf(pg,ds,buf,len,ch,display) +; Where ---- pg: logical page of the block +; ds: block displacement +; buf: address of print buffer +; len: number of chars in the block +; ch: character to escape (| for syms, " for strs) +; display: whether to use escape characters +; Returns the number 2n+s, where n is the number of characters in the +; print buffer, and s=1 if strange chars were encountered, 0 otherwise. +; Popping order: return address, pg, ds, buf, len, ch, display + public blk2pbuf + extrn hicases:byte +blk2pbuf proc near + pop DX ;Pop return address + pop BX ;Pop page + shl BX,1 ;Put segment of block in DS + LoadPage DS,BX +;;; mov DS,pagetabl+[BX] + pop SI ;Pop block displacement + pop DI ;Pop print buffer + pop CX ;Pop character count + pop BX ;Pop must-be-escaped character + pop AX ;Pop whether to use escapes + mov BH,AL ;Save escape boolean in BX + and BH,7fh ;Save bit in BH for strangeness + push DX ;Push return address + push ES ; Save caller's ES register + mov DX,DI ;Save start address of print buffer in DX + jcxz zstrng ;If len=0, mark strangeness + cmp BL,'"' ;Are we looking at a string? + jne b2plp ;Skip if not +zstrng: or BH,80h ;Otherwise, mark as strange + jcxz done ;If len=0, forget everything else +b2plp: lodsb ;Fetch char from block + test BH,7fh ;Are we displaying escape chars? + jz storit ;Jump if not + cmp AL,BL ;Does the char need escaping? + je escit ;If needed, do so + cmp AL,'\' + jne storit ;If not, just store it +escit: mov AH,AL ;Save char in AH + mov AL,'\' ;Store escape character + stosb + mov AL,AH ;Restore char +storit: stosb ;Store it + test BH,80h ;Do we already know that atom's strange? + jnz skptest ;If so, don't bother testing + push SI ;Else save SI + mov SI,offset DGROUP:hicases ;Point SI to table of upper cases + xchg BX,SI + mov AH,AL ;Save char in AH + xlat ES:hicases ;Fetch upper-case equivalent + xchg BX,SI ;Restore BX + cmp AH,AL + jne mrkstrng ;If chars different, mark as strange + mov SI,offset stranges ;Point SI to strange-character string +strnglp: lods byte ptr ES:[SI] ;Fetch strange char + or AL,AL ;End of string? + jz notstrng ;Jump if so + cmp AH,AL ;Is AH strange? + jne strnglp ;If not, try again +mrkstrng: or BH,80h ;Mark strange bit +notstrng: pop SI ;Restore SI +skptest: loop b2plp ;Repeat until done +done: push ES ;Restore DS + pop DS + pop ES ; Restore caller's ES register + mov byte ptr[DI],0 ;Put null at end of string + mov AX,DI ;Return 2*(# of chars in string)+strangeness + sub AX,DX + shl BH,1 + rcl AX,1 + ret ;Return +blk2pbuf endp +ENDIF + +; Load bignum block with long integer +; Calling sequence: putlong(reg,longi) +; Where ----- reg: register pointing to a bignum block +; longi: 32-bit integer to store +; Popping order: return address, register address, low & high integer words + public putlong +putlong proc near + pop DX ;Fetch return address + pop DI ;Fetch register address + mov BX,[DI].C_page ;Point ES:DI to bignum block + LoadPage ES,BX +;;; mov ES,pagetabl+[BX] + mov DI,[DI].C_disp + add DI,3 ;Point ES:DI to block data area + pop BX ;Put long integer in CX:BX + pop CX + xor AL,AL ;Sign byte - default positive + test CH,80h ;Integer negative? + jz poslong ;Jump if not + inc AL ;Otherwise, set sign negative + xor BX,-1 ;Negate long integer + xor CX,-1 + add BX,1 + adc CX,0 +poslong: cld ;Direction forward + stosb ;Store sign byte + mov AX,BX ;Store least significant word + stosw + jcxz notlong ;If most signif. word=0, don't store it + mov AX,CX + stosw +notlong: push DS ;Restore ES + pop ES + jmp DX ;Return +putlong endp + + +; Add word of zeros, if necessary, to bignum buffer +; Calling sequence: thefix(buf) +; Where ----- buf: address of bignum buffer +; THEFIX is intended to alleviate a problem in the bignum division package. +; Popping order: return address, buf + public thefix +thefix proc near + pop DI ;Return address in DX + pop SI ;Fetch bignum buffer address + mov BX,[SI] ;Get bignum size in words + inc BX ;Point BX+SI to last bignum byte + shl BX,1 + test byte ptr[BX+SI],80h ;Is most signif. bit set? + jz fixed ;If not, nothing to fix + inc word ptr[SI] ;Otherwise, increase bignum size + inc BX ;Add word of 0 to most significant end + mov word ptr[BX+SI],0 +fixed: jmp DI ;Return +thefix endp + + +; Load a long integer value with a bignum +; Calling sequence: ldlong(v, reg) +; Where ----- v: pointer to a long integer +; reg: register pointing to a bignum +; Returns 0 if the load was successful, 1 otherwise +; Popping order: return address, v, reg + public ldlong +ldlong proc near + pop DX ;Pop return address + pop DI ;Pop longint destination + pop BX ;Pop register address + push DS ;Save DS + mov SI,[BX].C_disp ;Point DS:SI to bignum object + mov BX,[BX].C_page + LoadPage DS,BX +;;; mov DS,pagetabl+[BX] + cld ;Direction forward + inc SI ;Put bignum length in CX + lodsw + mov CX,AX + lodsb ;Put bignum sign in BL + mov BL,AL + cmp CX,6 ;Check size + je big6 + cmp CX,8 + je big8 + mov AX,1 ;If here, bignum wrong size: error + pop DS ;Restore DS + jmp DX ;Return +big6: lodsw ;Put bignum in CX:AX + xor CX,CX + jmp short havenum +big8: lodsw ;Put bignum in CX:AX + mov CX,AX + lodsw + xchg CX,AX +havenum: test BL,1 ;Was bignum negative? + jz storenum ;No, skip + xor CX,-1 ;Otherwise, negate + xor AX,-1 + add AX,1 + adc CX,0 +storenum: stosw ;Store to long integer + mov AX,CX + stosw + xor AX,AX ;All's well + pop DS ;Restore DS + jmp DX ;Return +ldlong endp + + +; Move string bytes from one part of PCS memory to another +; Calling sequence: msubstr(to_reg, from_reg, start, end) +; Where ----- to_reg: register pointing to destination string +; from_reg: register pointing to source string +; start: offset at which to start copying +; end: byte after the last to be copied +; Popping order: return address, from_reg, to_reg, start, end + public msubstr +msubstr proc near + pop DX ;Pop return address (temporarily) + pop DI ;Pop destination register address + pop SI ;Pop source register address + pop AX ;Pop start index + pop CX ;Pop end index + push DS ;Save caller's DS & ES + push ES + mov BX,[DI].C_page ;Point ES:DI to destination object + mov DI,[DI].C_disp + LoadPage ES,BX +;;; mov ES,pagetabl+[BX] + add DI,BLK_OVHD ;Adjust DI past string overhead + mov BX,[SI].C_page ;Point DS:SI to source object + mov SI,[SI].C_disp + LoadPage DS,BX +;;; mov DS,pagetabl+[BX] + add SI,BLK_OVHD ;Adjust SI past string overhead + add SI,AX ;Point SI to start of substring + sub CX,AX ;Set number of bytes to move + cld ;Direction forward + rep movsb + pop ES ;Restore caller's DS & ES + pop DS + jmp DX ;Return +msubstr endp + +; Compare two Scheme bignums or strings for equal?-ness +; Calling sequence: mcmpstr(reg1,reg2) +; Where ----- reg1,reg2: registers pointing to objects to be compared +; Returns 1 if the objects are equal?, 0 otherwise + public mcmpstr +mcmpstr proc near + pop DX ;Pop return address + pop SI ;Pop register addresses + pop DI + push DS ;Save caller's DS and ES + push ES + mov BX,[DI].C_page ;Point ES:DI to second object + mov DI,[DI].C_disp + LoadPage ES,BX +;;; mov ES,pagetabl+[BX] + mov BX,[SI].C_page ;Point DS:SI to the first object + mov SI,[SI].C_disp + LoadPage DS,BX +;;; mov DS,pagetabl+[BX] + mov CX,[SI].str_len ;Fetch byte count from source's length + cmp CX,0 ;;; check for small string + jge mcm_010 + add CX,BLK_OVHD+PTRSIZE +mcm_010: xor AX,AX ;Default AX to FALSE + cld ;Direction forward + repe cmpsb ;Compare + jne cmpskp ;If not equal, return FALSE + inc AX ;Otherwise return TRUE +cmpskp: pop ES ;Restore caller's ES and DS + pop DS + jmp DX ;Return +mcmpstr endp + + +; Load a register with a pointer from Scheme memory +; Calling sequence: ldreg(reg,pg,ds) +; Where ----- reg: register to be loaded +; pg,ds: page and displacement of Scheme pointer +; Popping order: return address, reg, pg, ds + public ldreg +ldreg proc near + pop DX ;Pop return address + pop DI ;Pop destination register + pop BX ;Pop page and displacement + pop SI + mov CX,DS ;Save caller's DS + shl BX,1 ;Point DS:SI to Scheme pointer + LoadPage DS,BX +;;; mov DS,pagetabl+[BX] + cld ;Direction forward + lodsb ;Load register's page field + xor AH,AH + mov ES:[DI].C_page,AX + lodsw ;Load displacement field + mov ES:[DI].C_disp,AX + mov DS,CX ;Restore caller's DS + jmp DX ;Return +ldreg endp + + +; Generate pseudorandom numbers in the range 0-16,383 +; +; Author: John C. Jensen (converted to assembly lang. by Mark Meyer) +; Date Written: 9 January 1985 +; Last Modification: 9 July 1985 +; +; Calling Sequence: krandom() +; +; Note: the following random number generator is due to Jaroslav +; Kral. It was adapted to 16 bit words and proven both efficient +; and statistically satisfactory by Overstreet and Nance of SMU. +; See Karl's paper for initialization values for other word +; lengths. +; +; -- Kral, Jaroslav. "A New Additive Pseudorandom Number +; Generator for Extremely Short Word-Lengths," Information +; Processing Letters, 1 (1972), 164-167 (erratum noted in 1 +; (1972), 216). +; +; -- Overstreet, C. and Nance, R.E., "A Random Number Generator +; for Small Word-Length Computers," Proceedings of the ACM '73 +; Conference, p. 219-223. +; + public krandom +krandom proc near + mov AX,krala ;Put old KRALA in AX, old KRALB in BX + mov BX,kralb + mov CX,BX ;KRALC = KRALB + add BX,AX ;KRALB = (KRALA+KRALB) mod 2^n + and BH,3fh ; (Currently, n=14) + mov kralb,BX + mov BL,BH ;J = KRALB / 2^(n-4) + shr BL,1 + and BX,01eh + mov AX,[BX]+offset kraltbl ;KRALA = KRALTBL[J] + mov krala,AX + add AX,CX ;KRALTBL[J] = (KRALA+KRALC) mod 2^n + and AH,3fh + mov [BX]+offset kraltbl,AX + ret ;Return KRALTBL[J] +krandom endp + +; RANDOMIZE - Reset the random number registers and table back to their +; original values, then put the seed value into "kralb". +; Calling sequence: randomize(seed) ;seed = normal C int + public randomiz +randz_args struc + dw ? ;caller's ES + dw ? ;caller's BP + dw ? ;return address +rseed dw ? ;argument 1 (seed) +randz_args ends +randomiz proc near + push BP ;save caller's BP + push ES ;save ES + mov BP,SP ;establish local addressability + mov AX,DS ;copy DS to ES + mov ES,AX + mov CX,kral_len/2 ;restore random state to its original state + lea SI,krala1 + lea DI,krala + rep movsw + mov BX,[BP].rseed ;get seed + cmp BX,0 ;is it zero? + jnz randz_1 ;no, jump; use the seed directly + mov AX,2C00h ;get the time from DOS + int 21h + push DX ;tempsave DX (seconds, hundredths) + xor AX,AX + mov AL,CH ;determine #sec-in-hours + mov DX,3600 + mul DX + mov BX,AX + xor AX,AX + mov AL,CL ;determine #sec-in-minutes + mov DX,60 + mul DX + add BX,AX ;#sec-in-hours + #sec-in-minutes + pop DX ;restore seconds (and hundredths, but ignore it) + xchg DH,DL + mov DH,0 + add BX,DX ;add in seconds +randz_1: mov kralb,BX ;set seed + pop ES ;wrap up + pop BP + ret +randomiz endp + + +; Set the cdr field of a list cell +; Calling sequence: asetcdr(creg, preg) +; Where ---- creg: register pointing to cell +; preg: register holding new pointer +; Popping order: Return address, destination register, pointer register + public asetcdr +asetcdr proc near + pop DX ;Pop return address + pop DI ;Pop address of register + mov CX,ES ;Save caller's ES + mov BX,[DI].C_page ;Point ES:DI to list cell + mov DI,[DI].C_disp + LoadPage ES,BX +;;; mov ES,pagetabl+[BX] + add DI,PTRSIZE ;Adjust for cdr field + pop SI ;Pop address of pointer + cld ;Direction forward + mov AX,[SI].C_page ;Store into cdr field + stosb + mov AX,[SI].C_disp + stosw + mov ES,CX ;Restore ES + jmp DX ;Return +asetcdr endp + + +; Get field values from a port object +; Calling sequence: pt_flds4(reg, &ull, &ulc, &nl, &nc) +; pt_flds6(reg, &cl, &cc, &ull, &ulc, &nl, &nc) +; Where ----- reg: register pointing to port +; cl: variable to receive CUR_LINE value +; cc: ... CUR_COL value +; ull: ... UL_LINE value +; ulc: ... UL_COL value +; nl: ... N_LINES value +; nc: ... N_COLS value +; Warning: This routine expects these six fields to be contiguous +; Popping order: return address, reg, (&cl, &cc,) &ull, &ulc, &nl, &nc + public pt_flds4,pt_flds6 +pt_flds proc near +pt_flds6: mov CX,pt_cline ;Set CX to offset of first field + jmp fldsmrg +pt_flds4: mov CX,pt_ullin ;Set CX to offset of first field +fldsmrg: pop DX ;Pop return address + mov AX,DS ;Save caller's DS + pop BX ;Pop register address + mov SI,[BX].C_disp ;Point DS:SI to first field + mov BX,[BX].C_page + LoadPage DS,BX +;;; mov DS,pagetabl+[BX] + add SI,CX + cld ;Direction forward + sub CX,pt_cline ;Set CX to number of fields to do + shr CX,1 ; (6 - (1/2)(CX - pt_cline)) + neg CX + add CX,6 +fldslp: pop DI ;Pop destination variable address + movsw ;Transfer value + loop fldslp ;Repeat until done + mov DS,AX ;Restore DS + jmp DX ;Return +pt_flds endp + +; Copy bytes from one C location to another +; Calling sequence: str2str(dest_adr, src_adr, n) +; Where ----- dest_adr: destination address +; src_adr: source address +; n: number of bytes to copy +; Popping order: return address, dest_adr, src_adr, n + public str2str +str2str proc near + pop DX ;Pop return address + pop DI + pop SI + pop CX + cld ;Direction forward + rep movsb ;Copy bytes + jmp DX ;Return +str2str endp + +; Adjust window region variables for presence of a border +; Calling sequence: adj4bord(&ull, &nl, &ulc, &nc) +; Where ----- ull: Upper-left-line variable +; nl: Number-of-lines variable +; ulc: Upper-left-column variable +; nc: Number-of-columns variable +; Popping order: return address, &ull, &nl, &ulc, &nc + public adj4bord +max_lines equ 25 +max_cols equ 80 +adj4bord proc near + pop DX ;Pop return address + mov BX,max_lines ;Expand HEIGHT of window region +expand: pop SI ;Pop upper-left parameter + pop DI ;Pop extent parameter + mov AX,[SI] ;Get value of upper-left parm + or AX,AX ;If zero, + jz expand1 ; skip next two instructions + dec word ptr[SI] ;Else, expand backward + inc word ptr[DI] + dec AX ;Adjust AX to match upper-left parm +expand1: add AX,[DI] ;Find opposite edge + cmp AX,BX ;If edge too far, + jae expand2 ; skip next instruction + inc word ptr[DI] ;Else, expand forward +expand2: cmp BX,max_cols ;If we're finished, + je adjex ; jump out + mov BX,max_cols ;Else, expand WIDTH of window region + jmp expand +adjex: jmp DX ;Return +adj4bord endp + +prog ends + end + \ No newline at end of file diff --git a/sutil.asm b/sutil.asm new file mode 100644 index 0000000..7a0c64b --- /dev/null +++ b/sutil.asm @@ -0,0 +1,802 @@ +; =====> SUTIL.ASM +;*************************************** +;* PC Scheme Runtime Support * +;* Misc Utilities * +;* * +;* (C) Copyright 1984.1985,1986 by * +;* Texas Instruments Incorporated. * +;* All rights reserved. * +;* * +;* Date Written: April 1984 * +;* Last Modification: 26 February 1986* +;*************************************** + include scheme.equ + include pcmake.equ + +;* Modification History: +;* 27 Jan 86 - Changed the code which looks for the TI Copyright notice +;* (JCJ) (when determining machine type) to search two areas instead +;* of just one. Now, checks are made at segment (paragraph) +;* offsets FC00 and FE00. +;* +;* 25 Feb 86 - Added the routine "put_ptr" to combine the "put_byte/put_word" +;* (JCJ) operations when a pointer is being stored into memory. +;* +;* 17 Feb 88 - Conditionally assemble XPCTYPE and PC_TYPE for Protected Memory +;* (TC) Scheme. These routines can be found in PRO2REAL.ASM and +;* REALIO.ASM for PROMEM + +DGROUP group data +data segment word public 'DATA' + assume DS:DGROUP + extrn _base:word +data ends + + +IFNDEF PROMEM + + ; See PRO2REAL.ASM for protected mode scheme + +XGROUP group PROGX +PROGX segment para public 'PROGX' + assume CS:XGROUP,DS:DGROUP +;************************************************************************ +;* Determine PC's Manufacturer * +;* * +;* Purpose: To determine whether or not we're running on a TIPC or * +;* another brand and set the "PC_MAKE" variable accordingly. * +;* Returns: PC_MAKE will contain 1 for TIPC or Business Pro in TI mode* +;* FF for IBM-PC * +;* FE for IBM-PC/XT * +;* FD for IBM-PC/jr * +;* FC for IBM-PC/AT or B-P in IBM mode * +;* 0 for undeterminable * +;************************************************************************ + public pc_type +XPCTYPE proc far + push ES ; save caller's ES register + push DI + mov AX,0FC00h ; move paragraph address of copyright +pc_002: mov ES,AX ; notice into ES + xor DI,DI ; Clear DI; 0 is lowest address in ROM @ES: + xor BX,BX ; Flag for "PC_MAKE" variable + mov CX,40h ; This'll be as far as I go... + mov AL,'T' ; look for beginning of "Texas Instruments" + cli ; Stop interrupts - bug in old 8088's +again: + repne scas byte ptr es:[di] ; SEARCH + or CX,CX ; Reach my limit? + jz short pc_005 ; quit if we've exhausted search + cmp byte ptr ES:[di],'e' ; make sure this is it + jne again ; use defaults if not found + cmp byte ptr ES:[di]+1,'x' ; really make sure this is it + jne again + push DS + mov DS,BX ; 0->DS for addressing low mem. + inc BX ; BX==1 => TIPC + mov AX,DS:word ptr [01A2h] ; If TIPC then what kind? + pop DS ; get DS back + add AL,AH ; checkout vector 68 bytes 2 & 3 + cmp AL,0F0h ; if AL==F0 then TIPC=Business Pro + jne pc_010 ; jump if not a B-P + in AL,068h ; Read from port + push AX ; Save for later + and AL,0FBh ; Enable CMOS + out 068h,AL ; Write back out + mov DX,8296h ; I/O address for B-P's mode byte + in AL,DX ; TI or IBM Mode on the B-P? + cmp AL,0 ; if not zero then B-P emulates a TIPC + pop AX ; Restore original port value + out 068h,AL ; and write back out + jne pc_010 ; jump if TIPC else IBM machine code is + ; where it should be. + jmp short pc_007 +pc_005: + mov AX,ES + cmp AH,0FEh ; test for segment offset FE00 + jae pc_007 ; two checks made? if so, jump + add AH,2 ; go back and check segment offset + jmp pc_002 ; FE00 +pc_007: mov AX,0F000h + mov ES,AX + mov al,byte ptr ES:0FFFEh ; IBM's machine code is @F000:FFFE + cmp AL,IBMTYPE ; Is this suckah an IBM? + jb pc_010 ; Jump if AL is below F0 (BX will be 0) + mov BL,AL +pc_010: sti ; Turn interrups back on + mov PC_MAKE,BX ; set variable PC_MAKE + pop DI + pop ES ; restore caller's ES register + ret ; return to caller +XPCTYPE endp +PROGX ends + + ; See PRO2REAL.ASM for above definition + +ENDIF + +PGROUP group prog +prog segment byte public 'PROG' + assume CS:PGROUP + +;For space and performance reasons, some procedures have been written in the +; following style: the arguments are popped off the stack, and the +; procedure ends in an indirect JMP instead of a RET. In this source file, +; the following are such procedures: +; zero_pag, zero_blk, get_byte, get_word, put_byte, put_word, +; get_flo, put_flo, get_str, put_str, get_sym, put_sym, +; make_ptr, alloc_fi, take_car, take_cdr + +; Return Value of Stack Segment Register (SS:) +;;; public _SS +;;;_SS proc near +;;; mov AX,SS +;;; ret +;;;_SS endp + +;;;; Return Value of Extra Segment Register (ES:) +;;; public _ES +;;;_ES proc near +;;; mov AX,ES +;;; ret +;;;_ES endp + +;;;; Return Value of Code Segment Register (CS:) +;;; public _CS +;;;_CS proc near +;;; mov AX,CS +;;; ret +;;;_CS endp + +; Return Value of Data Segment Register (DS:) + public _DS +_DS proc near + mov AX,DS + ret +_DS endp + +; Zero a page in memory - Calling sequence: zero_page(page_no) + public zero_pag +zero_arg struc + dw ? ; Return address +zero_pg dw ? ; Page number +zero_arg ends +zero_pag proc near + pop DX ;Pop return address + pop BX ;Pop page number + push ES ;Save ES + sal BX,1 + LoadPage ES,BX +;;; mov ES,DGROUP:pagetabl+[BX] + xor AX,AX + xor DI,DI + mov CX,psize+[BX] + shr CX,1 + cld + rep stosw + pop ES ;Restore ES + jmp DX +zero_pag endp + +;************************************************************************ +;* Zero a block of memory * +;* * +;* Purpose: To initialize a variable length block of memory to zero. * +;* * +;* Description: The block is zeroed using the 8088's "store string" * +;* instruction using a repeat count. For * +;* efficiency reasons, the zeroing is done by * +;* words, with a fixup to account for blocks with * +;* an odd number of bytes. * +;* * +;* Calling sequence: zero_blk(page_no, disp) * +;* where page_no = page number (C's unshifted * +;* page number) * +;* disp = displacement of block within * +;* the page * +;************************************************************************ + public zero_blk +zb_args struc + dw ? ; Return address +zb_page dw ? ; Page number +zb_disp dw ? ; Displacement +zb_args ends + +zero_blk proc near + pop SI ;Pop return address + pop BX ; Pop the page number for the block + shl BX,1 ; and adjust for use as index + pop DI ; Pop the displacement of the block + push ES ; save the caller's ES register + LoadPage ES,BX +;;; mov ES,DGROUP:pagetabl+[BX] ; load page's paragraph address + mov CX,ES:[DI].vec_len ; and the block's length + add DI,BLK_OVHD ; and advance pointer past block header + cmp CX,0 ;;; check for small string + jge zero_010 + add CX,PTRSIZE + jmp zero_020 +zero_010: sub CX,BLK_OVHD ; subtract block overhead from the length +zero_020: mov DX,CX ; copy the length in bytes, and + and DX,1 ; isolate the least significant bit + shr CX,1 ; convert number of bytes to number of words + xor AX,AX ; load a value of zero into AX + cld ; set forward direction + rep stosw ; zero the block + mov CX,DX ; copy the fixup byte count + rep stosb ; zero the last byte, if odd number of bytes + pop ES ; restore ES register + jmp SI ; return to caller +zero_blk endp + +; Fetch/Store byte/word +get_args struc ; Arguments Template + dw ? ; return address +get_page dw ? ; page number +get_disp dw ? ; displacement into page +get_val dw ? ; value (if a store operation) +get_args ends + +; Get a byte of data +; Calling sequence: data = get_byte(page, disp) +; where: page ----- page number +; disp ----- (byte) displacement within page + public get_byte +get_byte proc near + mov CX,ES ; save caller's ES in CX + pop SI ; get return address + pop BX ; get page argument + shl BX,1 ; adjust it for segment lookup + LoadPage ES,BX +;;; mov ES,pagetabl+[BX] ; get page segment + pop BX ; get displacement + mov AL,ES:[BX] ; get byte + xor AH,AH ; and only a byte + mov ES,CX ; restore ES + jmp SI ; return +get_byte endp + +; Get a word of data +; Calling sequence: data = get_word(page, disp) +; where: page ----- page number +; disp ----- (byte) displacement within page + public get_word +get_word proc near + mov CX,ES ; save caller's ES in CX + pop SI ; get return address + pop BX ; get page argument + shl BX,1 ; adjust it for segment lookup + LoadPage ES,BX +;;; mov ES,pagetabl+[BX] ; get page segment + pop BX ; get displacement + mov AX,ES:[BX] ; get word + mov ES,CX ; restore ES + jmp SI ; return +get_word endp + +; Put a byte of data +; Calling sequence: put_byte(page, disp, value) +; where: page ----- page number +; disp ----- (byte) displacement within page +; value ---- value to be stored (low order 8 bits) + public put_byte +put_byte proc near + mov CX,ES ; save caller's ES in CX + pop SI ; get return address + pop BX ; get page + sal BX,1 ; double page number for use as index + LoadPage ES,BX +;;; mov ES,pagetabl+[BX] ; load page's paragraph address + pop BX ; get displacement + pop AX ; load byte to store + mov byte ptr ES:[BX],AL ; store new data + mov ES,CX ; restore segment register ES + jmp SI ; return +put_byte endp + +; Put a word of data +; Calling sequence: put_word(page, disp, value) +; where: page ----- page number +; disp ----- (byte) displacement within page +; value ---- value to be stored (16 bits) + public put_word +put_word proc near + mov CX,ES ; save caller's ES in CX + pop SI ; get return address + pop BX ; load the page number + sal BX,1 ; double page number for use as index + LoadPage ES,BX +;;; mov ES,pagetabl+[BX] ; load page's paragraph address + pop BX ; load displacement + pop AX ; load word to store + mov word ptr ES:[BX],AX ; store new data + mov ES,CX ; restore segment register ES + jmp SI ; return +put_word endp + +; Exchange a byte of data +; Calling sequence: old_data = xch_byte(page, disp, value) +; where: old_data - original data (overwritten) +; page ----- page number +; disp ----- (byte) displacement within page +; value ---- value to be stored (low order 8 bits) +; public xch_byte +;xch_byte proc near +; mov CX,ES ; save caller's ES in CX +; pop SI ; get return address +; pop BX ; get page +; sal BX,1 ; double page number for use as index +; mov ES,pagetabl+[BX] ; load page's paragraph address +; pop BX ; get displacement +; pop AX ; load byte to store +; xchg AL,byte ptr ES:[BX] ; swap old and new data +; xor AH,AH ; clear high order byte of AX +; mov ES,CX ; restore segment register ES +; jmp SI ; return +;xch_byte endp + +; Exchange a word of data +; Calling sequence: old_data = xch_word(page, disp, value) +; where: old_data - original data (overwritten) +; page ----- page number +; disp ----- (byte) displacement within page +; value ---- value to be stored (16 bits) +; public xch_word +;xch_word proc near +; mov CX,ES ; save caller's ES in CX +; pop SI ; get return address +; pop BX ; load the page number +; sal BX,1 ; double page number for use as index +; mov ES,pagetabl+[BX] ; load page's paragraph address +; pop BX ; load displacement +; pop AX ; load word to store +; xchg AX,word ptr ES:[BX] ; swap old and new data +; mov ES,CX ; restore segment register ES +; jmp SI ; return +;xch_word endp + +; Put a pointer +; Calling sequence: put_word(page, disp, pg_value, ds_value) +; where: old_data - original data (overwritten) +; page ----- page number +; disp ----- (byte) displacement within page +; pg_value ---- value of page number to store (16 bits) +; ds_value ---- value of displacement to store (16 bits) + public put_ptr +put_ptr proc near + mov CX,ES ; save caller's ES in CX + pop SI ; get return address + pop BX ; load the page number + sal BX,1 ; double page number for use as index + LoadPage ES,BX +;;; mov ES,pagetabl+[BX] ; load page's paragraph address + pop BX ; load displacement + pop AX ; load page number value to store + mov byte ptr ES:[BX],AL ; store page number + pop AX ; load displacement value to store + mov word ptr ES:[BX]+1,AX ; store page number + mov ES,CX ; restore segment register ES + jmp SI ; return +put_ptr endp + +; Fetch/Store Flonum +getf_arg struc ; Arguments Template + dw ? ; caller's BP + dw ? ; return address +getf_pag dw ? ; page number +getf_dis dw ? ; displacement into page +getf_val dw ? ; value (if a store operation) +getf_arg ends + +; Get a floating point value +; Calling sequence: fdata = get_flo(page, disp) +; where: page ----- page number +; disp ----- (byte) displacement within page + public get_flo +get_flo proc near + pop DI ;Pop return address + pop BX ; load the page number + sal BX,1 ; double page number for use as index + pop SI ; load displacement + inc SI ; and advance page flonum's tag + push DS ; save the caller's DS segment register + LoadPage DS,BX +;;; mov DS,pagetabl+[BX] ; load page's paragraph address + cld ;Direction forward + lodsw ;Put the flonum in AX:BX:CX:DX + mov DX,AX + lodsw + mov CX,AX + lodsw + mov BX,AX + lodsw + pop DS ; restore caller's DS segment register + jmp DI ; return +get_flo endp + +; Put a flonum value into Scheme's memory +; Calling sequence: put_flo(page, disp, value) +; where: page ----- page number +; disp ----- (byte) displacement within page +; value ---- flonum value to be stored (4 words) + public put_flo +put_flo proc near + pop DX ;Pop return address + pop BX ; load the page number + sal BX,1 ; double page number for use as index + pop DI ; load displacement + inc DI ; and advance offset past flonum's tag + mov SI,SP ;SP points to flonum - point SI to it too + push ES ; save the caller's ES segment register + LoadPage ES,BX +;;; mov ES,pagetabl+[BX] ; load page's paragraph address + mov CX,FLOSIZE/WORDINCR ; load number of words to store + cld ; clear direction flag + rep movsw ; move the words of the flonum + pop ES ; restore the ES segment register + jmp DX ; return to caller +put_flo endp + +; Transfer string to/from Scheme's memory +s_args struc + dw ? ; Caller's BP + dw ? ; Return address +sptr dw ? ; Pointer to string in C's memory +spage dw ? ; page number +sdisp dw ? ; displacement in page +lpage dw ? ; link field page number (for symbols) +ldisp dw ? ; link field displacement (for symbols) +hash_key dw ? ; hash value (for symbols) +s_args ends + + public get_str,get_sym +get_str proc near + pop DX ;Pop return address + pop DI ; Fetch destination string's displacement + pop BX ; Fetch source page number + shl BX,1 ; Adjust page number for use as index + pop SI ; Fetch source string's displacement + push DS ;Save caller's DS + LoadPage DS,BX +;;; mov DS,pagetabl+[BX] ; Get source page's paragraph address + mov CX,[SI].vec_len ; Fetch length of string/symbol + add SI,offset vec_data ; Adjust for string header + cmp CX,0 ;;; check for small string + jge get_010 + add CX,PTRSIZE + jmp get_mrg +get_010: sub CX,offset vec_data ; Adjust length for string header +get_mrg: cld ; clear string direction + rep movsb ; move 'em out + pop DS ; Restore DS segment register + jmp DX ;Return +get_str endp + +get_sym proc near + pop DX ;Pop return address + pop DI ; Fetch destination string's displacement + pop BX ; Fetch source page number + shl BX,1 ; Adjust page number for use as index + pop SI ; Fetch source string's displacement + push DS ;Save caller's DS + LoadPage DS,BX +;;; mov DS,pagetabl+[BX] ; Get source page's paragraph address + mov CX,[SI].sym_len ; Fetch length of string/symbol + add SI,offset sym_data ; Adjust offset for symbol header + sub CX,offset sym_data ; Adjust length for symbol header + jmp get_mrg ;Get pname bytes +get_sym endp + + public put_str,put_sym +put_str proc near + pop DX ;Pop return address + pop SI ; Load source string offset + pop BX ; Load destination page number, + pop DI ; and displacement + shl BX,1 ; Adjust page number for use as index + push ES ; Save caller's ES segment register + LoadPage ES,BX +;;; mov ES,pagetabl+[BX] ; Load destination page paragraph address + mov CX,ES:[DI].vec_len ; Load string length + add DI,offset vec_data ; Adjust pointer for string header + cmp CX,0 ;;; check for small string + jge put_010 + add CX,PTRSIZE ;;; get the right string length + jmp putmrg +put_010: sub CX,offset vec_data ; Adjust length for string header +putmrg: cld ; Clear direction flag + rep movsb ; Move 'em in + pop ES ; Restore caller's ES + jmp DX ; Return +put_str endp + +put_sym proc near + pop DX ;Pop return address + pop SI ; Load source string offset + pop BX ; Load destination page number, + pop DI ; and displacement + shl BX,1 ; Adjust page number for use as index + mov CX,ES ;Save caller's ES in CX + LoadPage ES,BX +;;; mov ES,pagetabl+[BX] ; Load destination page paragraph address + pop AX ; Load link field page number and + mov ES:[DI].sym_page,AL ; and move into symbol structure + pop ES:[DI].sym_disp ; Store link field displacement + pop AX ; move hash value into symbol data object + mov ES:[DI].sym_hkey,AL + push CX ;Now move caller's ES to stack + mov CX,ES:[DI].sym_len ; Load string length + add DI,offset sym_data ; Adjust displacement for symbol header + sub CX,offset sym_data ; Adjust length for symbol header + jmp putmrg ; Move 'em in +put_sym endp + +; Convert page, displacement values to a long integer + public make_ptr +make_args struc + dw ? ; return address +mak_page dw ? ; page number +mak_disp dw ? ; pointer displacement +make_args ends + +make_ptr proc near + pop DI + pop AX + adjpage AX + pop BX + jmp DI +make_ptr endp + +; Allocate a cell for a fixnum (actually, return an immediate value) +; Calling sequence: alloc_fixnum(®, value) +a_fix_arg struc + dw ? ; Return address +a_reg dw ? ; Address of register to hold pointer +a_val dw ? ; Fixnum value +a_fix_arg ends + + public alloc_fi +alloc_fi proc near + pop DI ;Pop return address + pop SI ; Pop address of return register + pop DX ; Pop fixnum value + sal DX,1 ; Shift out high order bit + jo a_fix_ov +a_fix_ov: ; Ignore overflow for now (create a bignum later) + shr DX,1 ; Position 15 bit quantity + mov [SI].C_disp,DX ; Store immediate value into register + mov [SI].C_page,SPECFIX*2 ; Store immediate tag + jmp DI ;Return +alloc_fi endp + +;************************************************************************ +;* Copy Variable Length Data Object * +;* * +;* Purpose: To create a copy of a variable length Scheme data object. * +;* * +;* Calling Sequence: copy_blk(&dest, &src) * +;* where &dest - address of VM register into which * +;* pointer to new copy is to be * +;* placed * +;* &src - address of VM register containing * +;* block to be copied * +;************************************************************************ +cpy_args struc + dw ? ; caller's BP + dw ? ; caller's ES + dw ? ; return address +cpy_dest dw ? ; address of destination register +cpy_src dw ? ; address of source register +cpy_args ends + + public copy_blk +copy_blk proc near + push ES ; save caller's ES + push BP ; save caller's BP + mov BP,SP + +; allocate new block + mov SI,[BP].cpy_src ; load address of source register + mov BX,[SI].C_page ; load pointer to object to be copied + mov DI,[SI].C_disp + LoadPage ES,BX +;;; mov ES,pagetabl+[BX] + + mov AX,ES:[DI].vec_len ; load length of object + cmp AX,0 ;;; check for small string + jge copy_010 + add AX,PTRSIZE ;;; adjust for small string + jmp copy_011 +copy_010: sub AX,BLK_OVHD ; adjust size for block header +copy_011: push AX ; push length of "data" in block + + xor AX,AX ; load type field from source block + mov AL,ES:[DI].vec_type + push AX + + push [BP].cpy_dest ; push address of destination register + mov AX,DS ; make ES point to the current data + mov ES,AX ; segment + C_call alloc_bl ; allocate new block + mov SP,BP ; drop arguments off stack + +; copy contents of source block into newly created block + mov BX,[BP].cpy_dest ; make ES:[DI] point to newly created + mov DI,[BX].C_disp ; block + mov BX,[BX].C_page + LoadPage ES,BX +;;; mov ES,pagetabl+[BX] + + mov BX,[BP].cpy_src ; make DS:[SI] point to source block + mov SI,[BX].C_disp + mov BX,[BX].C_page + push DS + LoadPage DS,BX +;;; mov DS,pagetabl+[BX] + + mov CX,[SI].vec_len ; load length of source block + cmp CX,0 ;;; check for small string + jge copy_020 + add CX,PTRSIZE + jmp copy_021 +copy_020: sub CX,BLK_OVHD ; and subtract off size of block header +copy_021: mov DX,CX ; copy length (in bytes) into DX + and DX,1 ; and isolate the lsb + shr CX,1 ; convert size from bytes to words + + add SI,BLK_OVHD ; advance source/destination pointers + add DI,BLK_OVHD ; past block header +rep movsw ; move contents of source to destination + mov CX,DX ; copy fixup (in case odd number of bytes) +rep movsb ; copy odd byte, if necessary + pop DS ; restore DS + +; return to calling procedure + pop BP ; restore caller's BP + pop ES ; restore caller's ES + ret ; return +copy_blk endp + +;;;; Make sure we haven't overflowed C's runtime stack +;;; public chk_stk +;;;chk_stk proc near +;;; mov AX,SP +;;; cmp AX,_base +;;; ja chk_ret +;;; C_call gc_on +;;; C_call exit +;;;chk_ret: ret +;;;chk_stk endp + +;************************************************************************ +;* C callable Routine to Take car/cdr of a List * +;************************************************************************ +take_arg struc + dw ? ; caller's BP + dw ? ; return address +take_reg dw ? ; argument register address +take_arg ends + + public take_car +take_car proc near + pop DX ;Pop return address + pop SI ; load argument register address + mov BX,[SI].C_page ; load list's page number + cmp byte ptr ptype+[BX],LISTTYPE*2 ; it is a list, isn't it? + jne take_err ; if not a list, error (jump) + mov CX,ES ; save caller's ES + LoadPage ES,BX +;;; mov ES,pagetabl+[BX] ; load list's page's paragraph address + mov BX,[SI].C_disp ; load list's offset + mov AL,ES:[BX].car_page ; copy car field of list cell + mov BX,ES:[BX].car + jmp short tkmrg +; ***error-- argument register doesn't contain list-- return nil*** +take_err: mov [SI].C_page,NIL_PAGE*2 + mov [SI].C_disp,NIL_DISP + jmp DX ; return +take_car endp + + public take_cdr +take_cdr proc near + pop DX ;Pop return address + pop SI ; load argument register address + mov BX,[SI].C_page ; load list's page number + cmp byte ptr ptype+[BX],LISTTYPE*2 ; it is a list, isn't it? + jne take_err ; if not a list, error (jump) + mov CX,ES ; save caller's ES + LoadPage ES,BX +;;; mov ES,pagetabl+[BX] ; load list's page's paragraph address + mov BX,[SI].C_disp ; load list's offset + mov AL,ES:[BX].cdr_page ; Get cdr field of list cell + mov BX,ES:[BX].cdr +tkmrg: mov byte ptr [SI].C_page,AL ; Copy into argument register + mov [SI].C_disp,BX + mov ES,CX ; restore caller's ES + jmp DX ; return to caller +take_cdr endp + + +IFNDEF PROMEM + + ; See PRO2REAL.ASM for protected mode scheme + + public pc_type +pc_type proc near + push BP + call XPCTYPE ; XPCTYPE is located at beginning of this + ; program in XPROG, it determines PC type + pop BP + ret +pc_type endp + + public pcinit + extrn XPCINIT:FAR +pcinit proc near + push BP + call XGROUP:XPCINIT ; XPCINIT is in GRAPHCMD.ASM - in XPROG + ; it does special initialization per PC type + ; also, it is called from main() + pop BP + ret +pcinit endp + + ; See PRO2REAL.ASM for above definitions + +ENDIF + +;************************************************************************ +;* Symbol Hashing Routine * +;* * +;* Calling Seguence: hash_value = hash(symbol, len); * +;************************************************************************ + public hash +hash proc near + pop DI ; unload return address + pop SI ; fetch symbol "string" pointer + pop CX ; fetch length + xor BX,BX ; zero accumulator + xor AH,AH +hash_1: lodsb ; fetch next character in symbol name + add BX,AX ; sum them up + loop hash_1 ; iterate 'til symbol used up + mov AX,BX ; copy sum of chars to AX + xor DX,DX + mov BX,HT_SIZE ; load divisor with hash table size + div BX ; divide sum + mov AX,DX + jmp DI ; return to caller +hash endp + +;************************************************************************ +;* Symbol Equality Routine * +;* * +;* Calling Sequence: equal? = sym_eq(page, disp, symbol, len); * +;************************************************************************ + public sym_eq +sym_eq proc near + pop DX ; unload return address + pop BX ; fetch page number + shl BX,1 ; and adjust for word indexing + pop DI ; fetch displacement + pop SI ; fetch pointer to symbol name + pop CX ; fetch length + mov AX,ES ; save value of ES + LoadPage ES,BX +;;; mov ES,pagetabl+[BX] ; laod symbol page's paragraph address + mov BX,ES:[DI].sym_len ; fetch length of symbol + sub BX,offset sym_data ; and compute character count + cmp CX,BX ; length of symbol match? + jne not_eq ; if not same length, jump + add DI,offset sym_data ; advance symbol pointer to print name +repe cmpsb ; compare symbol to name + jne not_eq ; symbols the same? if not, jump + mov ES,AX ; restore caller's ES register + jmp DX ; return (non-zero value in AX => true) +not_eq: mov ES,AX ; restore caller's ES register + xor AX,AX ; zero AX (return false value) + jmp DX ; return +sym_eq endp +prog ends + end + \ No newline at end of file diff --git a/svars.asm b/svars.asm new file mode 100644 index 0000000..241fd96 --- /dev/null +++ b/svars.asm @@ -0,0 +1,958 @@ +; =====> SVARS.ASM +;**************************************** +;* TIPC Scheme '84 Runtime Support * +;* Interpreter -- Variable Operations * +;* * +;* (C) Copyright 1984, 1985, 1988 * +;* Texas Instruments Incorporated. * +;* All rights reserved. * +;* * +;* Date Written: 24 July 1984 * +;* Modification History: * +;* ?? 10/22/85 - ?? * +;* rb 2/ 5/88 - MEMV, ASSV use EQV's * +;* definition of number equality * +;* (which is "=", *not* "equal"). * +;* * +;**************************************** + + include scheme.equ + include sinterp.mac + + include sinterp.arg + +DGROUP group data +data segment word public 'DATA' + assume DS:DGROUP +m_fluid db "LD-FLUID",0 +m_setfl db "SET-FLUID!",0 +m_set_gl db "SET!-GLOBAL",0 +m_fl_p db "FLUID-BOUND?",0 +m_ve_al db "MAKE-VECTOR",0 +m_vec_s db "VECTOR-SIZE",0 +m_vecf db "VECTOR-FILL!",0 +m_mkvt_a dw m_ve_al ; address of "MAKE-VECTOR" +m_one dw 1 ; a constant "one" (1) +m_three dw 3 ; a constant "three" (3) +m_toobig dw VECTOR_SIZE_LIMIT_ERROR ; numeric error code +data ends + +PGROUP group prog +prog segment byte public 'PROG' + assume CS:PGROUP + +var_int 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 ; mov SP,BP before next_PC + extrn src_err:near ; "source operand error" message display + extrn sch_err:near ; Link to Scheme debugger + +;************************************************************************ +;* Macro support for global/fluid variable lookup * +;************************************************************************ +load macro environ,err_msg,reg_p + local x,y + lods word ptr ES:[SI] ; load dest reg, constant number + save ; save current location pointer + mov BL,AL ; copy destination register number + mov DI,BX ; into TIPC register DI + mov BL,AH ; isolate constant number +IFIDN , + mov SI,reg0_pag+[BX] ; load page number from symbol operand reg + mov AX,reg0_dis+[BX] ; likewise for the displacement +ELSE + mov AX,BX ; BX <- constant number * 3 + shl AX,1 + add BX,AX + add BX,CB_dis ; add offset for start of code block + xor AX,AX + mov AL,ES:[BX].cod_cpag ; load symbol's page number + mov SI,AX + mov AX,ES:[BX].cod_cdis ; load symbol's displacement +ENDIF + cmp byte ptr ptype+[SI],SYMTYPE*2 ; reg hold a symbol pointer? + jne y ; if not, jump to error handler + push DI ; save register number + mov DX,SI ; copy symbol's page number into DX + mov DI,environ&_pag ; load fluid environment pointer + mov SI,environ&_dis +;;; LoadPage ES,DI +;;; mov ES,pagetabl+[DI] ; load paragraph address for env. header + mov BX,DI ; BX <= page number + call lookup ; search the environment for symbol + cmp BX,0 ; symbol found? + pop BX ; restore register number + je x ; if symbol not found, jump + mov AX,ES:[DI].cdr ; load symbol's value pointer + mov reg0_dis+[BX],AX ; and store into register + mov AL,ES:[DI].cdr_page + mov byte ptr reg0_pag+[BX],AL + jmp next_PC +; symbol not found-- return '***unbound*** +x: mov CX,offset environ&_reg ; load address of environment reg + corrpage DX ; adjust page number for call to C routine + add BX,offset reg0 ; compute address of destintatin register + pushm ; push page, displacement, env, dest reg + C_call sym_unde,,Load_ES ; call: symbol_undefined(pg,ds,env,dest) +;***x: mov reg0_dis+[BX],UN_DISP +;*** mov byte ptr reg0_pag+[BX],UN_PAGE*2 + restore ; load next instruction's offset and + sub SI,3 ; back up PC to retry fluid load + jmp sch_err ; Link to Scheme debugger +; error-- register doesn't contain a symbol +y: lea BX,err_msg + jmp src_err ; display error message + endm + +;************************************************************************ +;* AL AH * +;* Fluid lookup FLUID dest,const * +;* * +;* Purpose: Interpreter support for fluid variable lookup * +;************************************************************************ + public ld_fluid +ld_fluid: load FNV,m_fluid,CONST + +;************************************************************************ +;* AL AH * +;* Fluid lookup-register operand FLUID-R dest,sym * +;* * +;* Purpose: Interpreter support for fluid variable lookup * +;************************************************************************ + public ld_fl_r +ld_fl_r: load FNV,m_fluid,REG + + purge load + +;************************************************************************ +;* AL AH * +;* set-fluid! ST-FLUID src,const * +;* * +;* Purpose: Interpreter support for fluid assignment. * +;************************************************************************ + public st_fluid +st_fluid: lods word ptr ES:[SI] ; load source reg and constant number + save ; save current value of location pointer + push AX ; save symbol/value register numbers + mov BL,AH + mov AX,BX ; BX <- constant number * 3 + shl AX,1 + add BX,AX + add BX,CB_dis ; add in starting offset of code block + xor AX,AX + mov AL,ES:[BX].cod_cpag ; load pointer to search symbol + mov DI,AX + cmp byte ptr ptype+[DI],SYMTYPE*2 ; really a symbol? + jne setfl_er ; if not, jump + mov DX,DI ; copy symbol's page number + mov AX,ES:[BX].cod_cdis ; load symbol's displacement + mov DI,FNV_pag ; load pointer to fluid environment + mov SI,FNV_dis +;;; LoadPage ES,DI +;;; mov ES,pagetabl+[DI] + mov BX,DI ; Page number + call lookup ; search fluid environment for symbol + cmp BX,0 ; symbol found in fluid environment? + je setfl_nf ; if not, error (jump) + pop AX ; restore operands + mov BL,AL ; copy source register number + mov AL,byte ptr reg0_pag+[BX] ; set cdr of fluid var entry + mov ES:[DI].cdr_page,AL ; to value in register + mov AX,reg0_dis+[BX] + mov ES:[DI].cdr,AX + jmp next_PC ; return to interpreter +; error-- symbol register doesn't contain a symbol pointer +setfl_er: mov BX,offset m_setfl ; load error message text + jmp src_err ; jump to "source error" routine +; error-- symbol not fluidly bound +setfl_nf: pop CX ; restore instruction's operands + xor CH,CH ; clear high order byte (constant number) + add CX,offset reg0 ; compute address of source register + corrpage DX ; convert page number to C's notation + pushm ; push arguments for error call + C_call not_flui,,Load_ES ; call error routine + restore ; back up location pointer to retry + sub SI,3 ; the set-fluid! operation + jmp sch_err ; link to Scheme debugger + +; fluid-bound? FLUID? reg + public fluid_p +fluid_p: lods byte ptr ES:[SI] ; load the register number for test + save ; save the current location pointer + mov BX,AX ; copy register number of symbol + mov AX,reg0_dis+[BX] + mov DX,reg0_pag+[BX] + mov DI,DX + cmp byte ptr ptype+[DI],SYMTYPE*2 ; symbol pointer? + jne fl_p_er ; if not, error (jump) + mov DI,FNV_pag + mov SI,FNV_dis +;;; LoadPage ES,DI +;;; mov ES,pagetabl+[DI] + push BX + mov BX,DI ; Page number + call lookup + cmp BX,0 + pop BX + je fl_p_nf +; symbol is fluidly bound-- return 't + mov AL,T_PAGE*2 + mov byte ptr reg0_pag+[BX],AL + mov AX,T_DISP + mov reg0_dis+[BX],AX + jmp next_PC +; symbol not in fluid environment-- return 'nil +fl_p_nf: xor AX,AX + mov byte ptr reg0_pag+[BX],AL + mov reg0_dis+[BX],AX + jmp next_PC +; error-- operand of (fluid-bound? obj) is not a symbol +fl_p_er: lea BX,m_fl_p + jmp src_err ; display error message + +;************************************************************************ +;* AL AH * +;* Bind fluid variable BIND-FL const,src * +;* * +;* Purpose: Interpreter support for binding (creating and defining) * +;* fluid variables * +;* * +;* Note: At entry to this routine, ES is set to point to the beginning * +;* of the page containing the current code block. * +;************************************************************************ + public bind_fl +bind_fl: lods word ptr ES:[SI] ; load src register, constant number + mov BL,AH ; copy the source register number + lea DI,reg0+[BX] ; and compute its address +; tmp_reg <- symbol + mov BL,AL ; BX <- constant number * 3 + mov AX,BX + shl AX,1 + add BX,AX + add BX,CB_dis ; add displacement of current code block + xor AX,AX + mov AL,ES:[BX].cod_cpag ; copy the symbol pointer into the + mov tmp_page,AX ; temporary register + mov AX,ES:[BX].cod_cdis + mov tmp_disp,AX +; cons(tmp_reg, tmp_reg, value) + mov AX,offset tmp_reg ; load address of temporary register + pushm ; push arguments to "cons" + C_call cons,,Load_ES ; create (cons symbol value) +; cons(FNV, tmp_reg, FNV) + mov AX,offset tmp_reg ; load address of temporary register + mov BX,offset FNV_reg ; load addr of fluid environment register + pushm ; push arguments to "cons" + C_call cons ; create (cons (cons symbol value) FNV) + jmp next_SP ; return to interpreter + +;************************************************************************ +;* Unbind fluid variable UNBIND-FL const * +;* * +;* Purpose: Interpreter support for unbinding (deleting) fluid * +;* variables * +;* * +;* Description: The fluid environment is maintained as an a-list, so * +;* dropping fluids consists of cdr-ing down the list for * +;* the required number of elements. * +;************************************************************************ + public unbind_f +unbind_f: lods byte ptr ES:[SI] ; load the count of fluids to drop + mov DX,ES ; save code block's paragraph address + mov CX,AX ; copy the drop count into CX + mov BL,byte ptr FNV_pag ; load the fluid environment pointer + mov DI,FNV_dis +unb_fl: LoadPage ES,BX +;;; mov ES,pagetabl+[BX] ; load entry's paragraph address + mov BL,ES:[DI].cdr_page ; load cdr field of entry + mov DI,ES:[DI].cdr + loop unb_fl ; continue cdr'ing for desired count + mov byte ptr FNV_pag,BL ; re-define the fluid environment + mov FNV_dis,DI ; register + mov ES,DX ; restore code block paragraph address + jmp next ; return to interpreter + +;************************************************************************ +;* Allocate vector VEC-ALLOCATE dest * +;* * +;* Purpose: Interpreter support for the allocation of vector data * +;* objects. * +;* * +;* Note: Vectors are set to zero after they are allocated to insure * +;* that all entries are valid Scheme pointers. Zeroing a * +;* vector effectively sets all the entries to nil. * +;* If an array were not initialized, the garbage collector * +;* would interpret any leftover data as pointers, and * +;* might cause the Scheme Virtual Machine to go off the * +;* deep end. * +;************************************************************************ + public vec_allo +vec_allo: lods byte ptr ES:[SI] ; load destination register number + save ; save the location pointer + mov BX,AX ; and copy it to TIPC register BX + add BX,offset reg0 + cmp byte ptr [BX].C_page,SPECFIX*2 ; is size a fixnum? + jne ve_al_er ; if not, error (jump) + mov AX,[BX].C_disp ; load immediate value from register + shl AX,1 ; and sign extend it + sar AX,1 + cmp AX,0 ; value positive? + jl ve_al_er ; if not, error (jump) + cmp AX,10921 ; check against maximum vector size + ja v_toobig ; if too many elements, error (jump) + mov CX,AX ; AX <- AX * 3 (multiply number of + shl AX,1 ; elements by size of pointer) + add AX,CX + mov CX,VECTTYPE ; load type of block to allocate + pushm ; push arguments + C_call alloc_bl,,Load_ES ; call: alloc_block(®, type, size) + pop BX ; recover address of reg holding vector ptr + mov AX,[BX].C_page ; fetch page number from destination reg + corrpage AX ; correct for C callable routine + pushm <[BX].C_disp,AX> ; push page and displacement + C_call zero_blk ; call: zero_blk(page, disp) + jmp next_SP ; return to interpreter +; ***Error-- invalid source operand for vec-alloc*** +ve_al_er: mov SI,[BX].C_page ; load operand's page number + cmp byte ptr ptype+[SI],BIGTYPE*2 ; is it a bignum? + je v_toobig ; if so, print "vector too big" message + lea BX,m_ve_al ; otherwise, print "source operand" + jmp src_err ; error message +; ***Error-- vector too large*** +v_toobig: restore + sub SI,2 + pushm + C_call disassem,,Load_ES + pushm + C_call set_nume + jmp sch_err + + +;************************************************************************ +;* Vector size VECTOR-SIZE dest * +;* * +;* Purpose: Interpreter support for the vector-size function to return * +;* the number of elements in a vector data object. * +;* * +;* Description: The number of elements in a vector data object is * +;* determined by dividing the number of bytes (obtained * +;* from the block header of the vector data object) by the * +;* number of bytes in a pointer (3), and subtracting the * +;* overhead of the block header (3 bytes). * +;************************************************************************ + public vec_size +vec_size: lods byte ptr ES:[SI] ; load destination register number + mov BX,AX ; and copy into TIPC register BX + save ; save the location pointer + mov SI,reg0_pag+[BX] ; load page number field of register + cmp ptype+[SI],VECTTYPE*2 ; is object a vector? + jne vec_s_er ; if not, error (jump) + mov DI,reg0_dis+[BX] ; load displacement of vector + LoadPage ES,SI +;;; mov ES,pagetabl+[SI] ; load vector's page paragraph address + mov AX,ES:[DI].vec_len ; load size of object (in bytes), + xor DX,DX ; extend to double word, + mov CX,3 ; load divisor of three, + idiv CX ; divide no. bytes by pointer size + dec AX ; subtract off block overhead + mov reg0_dis+[BX],AX ; store number of elements + mov byte ptr reg0_pag+[BX],SPECFIX*2 ; set tag=fixnum + jmp next_PC ; return to interpreter +; ***error-- operand doesn't point to a vector data object*** +vec_s_er: lea BX,m_vec_s + jmp src_err ; display error message + + +;************************************************************************ +;* AL AH * +;* vector fill vec-fill vect,val* +;* * +;* Purpose: Scheme intepreter support for the vector-fill operation * +;************************************************************************ + public vec_fill +vec_fill: lods word ptr ES:[SI] ; load operands + save ; save location pointer + xor BX,BX + mov BL,AL ; copy number of register containing vector + mov DI,reg0_dis+[BX] ; load vector pointer + mov BL,byte ptr reg0_pag+[BX] + cmp byte ptr ptype+[BX],VECTTYPE*2 ; is it really a vector? + jne vecf_err ; if not, error (jump) + LoadPage ES,BX +;;; mov ES,pagetabl+[BX] ; load page address of vector's page + mov BL,AH ; copy pointer to fill value + mov AX,reg0_dis+[BX] ; load value to fill array + mov DL,byte ptr reg0_pag+[BX] + mov CX,ES:[DI].vec_len ; load vector length (in bytes) and + sub CX,BLK_OVHD ; subtract off overhead for block header + jle vecf_fin ; if zero length vector, we're done +vecf_lp: mov ES:[DI].vec_page,DL ; store value into current element + mov ES:[DI].vec_disp,AX ; of vector + add DI,PTRSIZE ; increment pointer into vector + sub CX,PTRSIZE ; decrement array size + jg vecf_lp ; if more elements to define, loop (jump) +vecf_fin: jmp next_PC ; return to Scheme interpreter +vecf_err: lea BX,m_vecf + jmp src_err + +;************************************************************************ +;* AL AH * +;* (memq obj,list) MEMQ dest,src* +;* * +;* Purpose: Scheme interpreter support for the memq primitive * +;************************************************************************ +; Support for SHIFT-BREAK-- restart operation +memq_sb: push m_three ; indicate instruction length = 3 + C_call restart ; link to Scheme debugger + + public memq +memq: lods word ptr ES:[SI] ; load operands + save ; save the current location pointer + mov BL,AL ; compute the destination register +memq_x: lea DI,reg0+[BX] ; address in TIPC register DI + mov AL,byte ptr [DI].C_page ; copy search object pointer + mov DX,[DI].C_disp ; into AL,DX (page, disp, respectively) + mov BL,AH ; copy pointer to search list + mov SI,reg0_dis+[BX] ; load contents of "list" register + mov BL,byte ptr reg0_pag+[BX] + jmp memq_go +memq_nxt: cmp byte ptr s_break,0 ; has shift-break been depressed? + jne memq_sb ; if interrupt, jump + mov BL,ES:[SI].cdr_page ; load cdr field and continue + mov SI,ES:[SI].cdr ; search +memq_go: cmp BL,0 ; nil pointer? + je memq_f ; if so, return nil (jump) + cmp byte ptr ptype+[BX],LISTTYPE*2 ; "list" object a list cell? + jne memq_f ; if not, return nil (jump) + LoadPage ES,BX +;;; mov ES,pagetabl+[BX] ; load paragraph address of list cell + cmp DX,ES:[SI].car ; does displacement field of car match obj? + jne memq_nxt ; if not, test next element in list (jump) + cmp AL,ES:[SI].car_page ; does page field of car match obj? + jne memq_nxt ; if not, test next element in list (jump) +; match found-- return pointer to current list cell + mov byte ptr [DI].C_page,BL ; set destination register to point + mov [DI].C_disp,SI ; to current list cell + jmp next_PC ; return to interpreter +; no match-- return 'nil +memq_f: xor AX,AX ; put null value into destination register + mov byte ptr [DI].C_page,AL + mov [DI].C_disp,AX + jmp next_PC ; return to interpreter + + +;************************************************************************ +;* AL AH * +;* (memv key,list) MEMV dest,src * +;* key, list * +;* * +;* Purpose: Scheme interpreter support for the memv primitive * +;************************************************************************ + +memv_sb: jmp memq_sb ; shift-break support-- link to debugger + + public memv +memv: lods word ptr ES:[SI] ; load operands + save ; save the current location pointer + mov BL,AL ; compute the destination register + mov DI,reg0_pag+[BX] ; load page number of search object +; The following 3 lines are sufficient for MEMV if EQV doesn't require +; an = test for numbers and only checks types instead. All the remaining +; code for MEMV is to handle =. +; test attrib+[DI],FLONUMS+BIGNUMS+STRINGS +; jz memv_x ; unless one of above types, use "memq" +; jmp short memv_y ; otherwise, use full "member" test + test attrib[DI],FIXNUMS+FLONUMS+BIGNUMS+STRINGS + jz memv_x ; unless one of above types, use "memq" + test attrib[DI],FIXNUMS+FLONUMS+BIGNUMS + jz memv_y ; for strings do "member" test +; key is a number + lea DI,reg0[BX] ; DI=address of VM reg containing key + mov BL,AH + lea SI,reg0[BX] ; SI=address of VM reg containing list + push [SI].C_page ; tempsave "list" VM reg + push [SI].C_disp + jmp short memv_nxt +memv_x: jmp memq_x ; these damn short relative jumps!! +memv_y: jmp member_x +; this list element didn't match, go to the next element +memv_more: cmp s_break,0 ; shift-break (IBM: control-break) pressed? + jne memv_sb ; yes, do break + mov BX,[SI].C_disp ; cdr our way down list + mov AL,ES:[BX].cdr_page + mov AH,0 + mov [SI].C_page,AX + mov AX,ES:[BX].cdr + mov [SI].C_disp,AX +; loop over each element in the list +memv_nxt: mov BX,[SI].C_page + cmp BX,NIL_PAGE ; at end of list? + je memv_f ; yes, jump + cmp byte ptr ptype[BX],LISTTYPE*2 ; looking at a cons? + jne memv_f ; no, jump + LoadPage ES,BX ; get cons into memory + mov BX,[SI].C_disp ; ES:BX=address of cons cell + mov BL,ES:[BX].car_page + mov BH,0 + test attrib[BX],FIXNUMS+FLONUMS+BIGNUMS ; is list elt numeric? + jz memv_more ; no, jump +; key and list element are both numeric + mov tmp_reg.C_page,BX + mov BX,[SI].C_disp + mov BX,ES:[BX].car + mov tmp_reg.C_disp,BX + lea BX,tmp_reg +; begin comparison of key and list element + cmp byte ptr [DI].C_page,SPECFIX*2 ; is key a fixnum? + jne memv_float ; no, jump + cmp byte ptr [BX].C_page,SPECFIX*2 ; is list elt a fixnum? + jne memv_float ; no, jump +; both key and list element are fixnums + mov AX,[BX] ; AX=list elt + mov DX,[DI] ; DX=key + shl AX,1 + shl DX,1 + cmp AX,DX ; same number? + jne memv_more ; no, jump +; we have a match, copy list object-pointer to VM register containing key +memv_t: mov AX,[SI].C_disp + mov [DI].C_disp,AX + mov AX,[SI].C_page + mov [DI].C_page,AX + jmp short memv_f1 +; we have no match, copy '() to VM register containing key +memv_f: xor AX,AX + mov [DI].C_page,AX + mov [DI].C_disp,AX +memv_f1: pop [SI].C_disp ; restore original contents "list" VM reg + pop [SI].C_page + jmp next_PC ; return to interpreter +; key and list element are not both fixnums, do = operation +memv_float: mov AX,EQ_OP + pushm ; save our state around C call + pushm ; list elt, key, operation + C_call arith2,,Load_ES ; do = + popm ; get C args off stack + popm ; restore our state + cmp AX,0 ; AX negative means "error" + jge memv_flo2 ; nope + jmp sch_err ; yes, go to error handler +memv_flo2: jg memv_t ; AX positive means "true" + jmp memv_more ; no match, go to next list element + + +;************************************************************************ +;* AL AH * +;* (member key,list) MEMBER dest,src * +;* key, list * +;* * +;* Purpose: Scheme interpreter support for the member primitive * +;************************************************************************ +memb_sb: jmp memq_sb ; shift-break support-- link to debugger + public member +member: lods word ptr ES:[SI] ; load operands + save ; save the current location pointer + mov BL,AL + mov DI,reg0_pag+[BX] ; load search object's page number + test attrib+[DI],FIXNUMS+SYMBOLS+CONTINU+CLOSURE+PORTS+CODE+CHARS + jz member_x ; if not one of these, use "equal?" compare + jmp memq_x ; otherwise, use "memq" test +member_x: lea DI,reg0+[BX] ; address in TIPC register DI + mov CL,byte ptr [DI].C_page ; load pointer to object in CL:DX + mov DX,[DI].C_disp + mov BL,CL + mov CH,byte ptr ptype+[BX] ; load type code of search object + mov BL,AH ; copy pointer to search list + mov SI,reg0_dis+[BX] ; load contents of "list" register + mov BL,byte ptr reg0_pag+[BX] + jmp memb_go +memb_mor: mov AX,BX + mov BL,ES:[SI].car_page + cmp CH,byte ptr ptype+[BX] + jne memb_nxt + pushm ; save registers across call + xor AX,AX + mov AL,ES:[SI].car_page + mov [BP].temp_reg.C_page,AX ; temp_reg <- (car list) + mov AX,ES:[SI].car + mov [BP].temp_reg.C_disp,AX + lea BX,[BP].temp_reg ; load address of temporary register + pushm ; push arguments + C_call sequal_p,,Load_ES ; call: sequal_p(&dest,&src) + pop DI ; retrieve destination register address + add SP,WORDINCR ; dump other arguments from stack + popm ; restore registers + LoadPage ES,BX ; restore page paragraph address + cmp AX,0 ; were values equal? + jne memb_fnd ; if so, jump +memb_nxt: cmp s_break,0 ; has shift-break key been depressed? + jne memb_sb ; if interrupt, jump + mov BL,ES:[SI].cdr_page ; load cdr field and continue + mov SI,ES:[SI].cdr ; search +memb_go: cmp BL,0 ; nil pointer? + je memb_f ; if so, return nil (jump) + cmp byte ptr ptype+[BX],LISTTYPE*2 ; "list" object a list cell? + jne memb_f ; if not, return nil (jump) + LoadPage ES,BX +;;; mov ES,pagetabl+[BX] ; load paragraph address of list cell + cmp DX,ES:[SI].car ; does displacement field of car match obj? + jne memb_mor ; if not, test next element in list (jump) + cmp CL,ES:[SI].car_page ; does page field of car match obj? + jne memb_mor ; if not, test next element in list (jump) +; "eq" match found-- return pointer to current list cell +memb_fnd: mov byte ptr [DI].C_page,BL ; set destination register to point + mov [DI].C_disp,SI ; to current list cell + jmp next_PC ; return to interpreter +; no match-- return 'nil +memb_f: xor AX,AX ; put null value into destination register + mov byte ptr [DI].C_page,AL + mov [DI].C_disp,AX + jmp next_PC ; return to interpreter + +;************************************************************************ +;* AL AH * +;* (assq obj,list) ASSQ obj,list* +;* * +;* Purpose: Scheme interpreter support for the assq primitive * +;************************************************************************ + public assq +assq: lods word ptr ES:[SI] ; load operands + save ; save the location pointer +assq_go: mov BL,AH ; copy the list register number + mov SI,reg0_pag+[BX] + cmp ptype+[SI],LISTTYPE*2 ; is second operand a list? + jne assq_err ; if not, error(?) (jump) + LoadPage ES,SI + mov DI,SI ; Save page number +;;; mov ES,pagetabl+[SI] ; load list page's paragraph address + mov SI,reg0_dis+[BX] ; load pointer to list operand + mov BL,AL ; load object register number + mov DX,reg0_pag+[BX] ; load pointer to search object + mov AX,reg0_dis+[BX] + push BX ; save destination register number + mov BX,DI ; Pass the page number + call lookup ; search list for eq? comparison of obj + pop SI ; restore destination register number + mov byte ptr reg0_pag+[SI],BL ; store result of search in + mov reg0_dis+[SI],DI ; the destination register + jmp next_PC ; return to interpreter +; ***second operand is not a list-- return nil*** +assq_err: mov BL,AL ; copy destination register number + xor AX,AX + mov byte ptr reg0_pag+[BX],AL ; store nil into destination + mov reg0_dis+[BX],AX ; register + jmp next_PC ; return to interpreter + +;************************************************************************ +;* AL AH * +;* (assv key,alist) ASSV key,alist * +;* * +;* Purpose: Scheme interpreter support for the assv primitive * +;************************************************************************ + +assv_sb: jmp memq_sb ; shift-break support-- link to debugger + + public assv +assv: lods word ptr ES:[SI] ; load operands + save ; save the location pointer + mov BL,AL ; get number of VM register containing key + mov DI,reg0_pag+[BX] ; load key's page number +; The following 3 lines are sufficient for ASSV if EQV doesn't require +; an = test for numbers and only checks types instead. All the remaining +; code for ASSV is to handle =. +; test attrib+[SI],FLONUMS+BIGNUMS+STRINGS ; one of these? +; jz assq_go ; if not one of above, use assq (jump) +; jmp short assoc_go ; if one of the above, use assoc + test attrib[DI],FIXNUMS+FLONUMS+BIGNUMS+STRINGS + jz assv_x ; unless one of above types, use "assq" + test attrib[DI],FIXNUMS+FLONUMS+BIGNUMS + jz assv_y ; for strings do "assoc" test +; key is a number + lea DI,reg0[BX] ; DI=address of VM reg containing key + mov BL,AH + lea SI,reg0[BX] ; SI=address of VM reg containing list + push [SI].C_page ; tempsave "alist" VM reg + push [SI].C_disp + jmp short assv_nxt +assv_x: jmp assq_go ; these damn short relative jumps!! +assv_y: jmp assoc_go +; this list element didn't match, go to the next element +assv_more: cmp s_break,0 ; shift-break (IBM: control-break) pressed? + jne assv_sb ; yes, do break + mov BX,[SI].C_page + LoadPage ES,BX ; get toplevel cons back into memory + mov BX,[SI].C_disp ; ES:BX=address of toplevel cons cell + mov AL,ES:[BX].cdr_page ; cdr down the alist + mov AH,0 + mov [SI].C_page,AX + mov AX,ES:[BX].cdr + mov [SI].C_disp,AX +; loop over each element in the list +assv_nxt: mov BX,[SI].C_page + cmp BX,NIL_PAGE ; at end of list? + je assv_f ; yes, jump + cmp byte ptr ptype[BX],LISTTYPE*2 ; looking at a cons? + jne assv_f ; no, jump + LoadPage ES,BX ; get toplevel cons into memory + mov BX,[SI].C_disp ; ES:BX=address of toplevel cons cell + push BX ; tempsave it + mov BL,ES:[BX].car_page + mov BH,0 + cmp byte ptr ptype[BX],LISTTYPE*2 ; is car of toplevel cons also a cons? + je assv_down ; yes, jump +assv_pop: pop BX ; normalize stack +assv_more1: jmp assv_more ; look at next toplevel cons +assv_down: mov DX,BX + pop BX ; (ES:BX=address of toplevel cons again) + mov BX,ES:[BX].car ; DX:BX=object ptr to 2nd level cons + LoadPage ES,DX ; ES:BX=address of 2nd level cons cell + push BX ; tempsave it + mov BL,ES:[BX].car_page + mov BH,0 + test attrib[BX],FIXNUMS+FLONUMS+BIGNUMS ; is its car numeric? + jz assv_pop ; no, jump + mov tmp_reg.C_page,BX ; yes, move car ptr into tmp_reg + pop BX ; (ES:BX=address of 2nd level cons again) + mov BX,ES:[BX].car + mov tmp_reg.C_disp,BX + lea BX,tmp_reg ; BX=address of tmp_reg +; begin comparison of key and list element + cmp byte ptr [DI].C_page,SPECFIX*2 ; is key a fixnum? + jne assv_float ; no, jump + cmp byte ptr [BX].C_page,SPECFIX*2 ; is list elt a fixnum? + jne assv_float ; no, jump +; both key and list element are fixnums + mov AX,[BX] ; AX=list elt + mov DX,[DI] ; DX=key + shl AX,1 + shl DX,1 + cmp AX,DX ; same number? + jne assv_more1 ; no, jump + jmp short assv_t +; we have no match, copy '() to VM register containing key +assv_f: xor AX,AX + mov [DI].C_page,AX + mov [DI].C_disp,AX +assv_f1: pop [SI].C_disp ; restore original contents "alist" VM reg + pop [SI].C_page + jmp next_PC ; return to interpreter +; we have a match, copy list object-pointer to VM register containing key +assv_t: mov BX,[SI].C_page + LoadPage ES,BX + mov BX,[SI].C_disp ; ES:BX=address of toplevel cons + mov AX,ES:[BX].car ; move car of this cons to dest. register + mov [DI].C_disp,AX + mov AL,ES:[BX].car_page + mov AH,0 + mov [DI].C_page,AX + jmp assv_f1 ; return to interpreter +; key and list element are not both fixnums, do = operation +assv_float: mov AX,EQ_OP + pushm ; save our state around C call + pushm ; list elt, key, operation + C_call arith2,,Load_ES ; do = + popm ; get C args off stack + popm ; restore our state + cmp AX,0 ; AX negative means "error" + jge assv_flo2 ; nope + jmp sch_err ; yes, go to error handler +assv_flo2: jg assv_t ; AX positive means "true" + jmp assv_more ; no match, go to next list element + + +;************************************************************************ +;* AL AH * +;* (assoc obj,list) ASSOC obj,list* +;* * +;* Purpose: Scheme interpreter support for the assoc primitive * +;* * +;* Register Usage: DX - address of destination register * +;* ES:SI - pointer to current list cell * +;************************************************************************ + public assoc +assoc: lods word ptr ES:[SI] ; load operands + save ; save the location pointer + mov BL,AL ; copy search object's register number + mov SI,reg0_pag+[BX] ; load search object's page number + test attrib+[SI],FIXNUMS+SYMBOLS+CONTINU+CLOSURE+PORTS+CODE+CHARS + jz assoc_go + jmp assq_go ; if one of the above, use assq (jump) +assoc_go: mov DX,BX ; copy obj's reg number into TIPC reg DX + add DX,offset reg0 ; compute address of search obj register + mov BL,AH ; copy list register number + mov SI,reg0_dis+[BX] ; load displacement pointer of "list" + mov BL,byte ptr reg0_pag+[BX] ; load page number of "list" +assoc_lp: cmp BL,0 ; end of list? (nil pointer?) + je assoc_nf ; if end of list, jump + cmp byte ptr ptype+[BX],LISTTYPE*2 ; is list operand a list? + jne assoc_er ; if not, error(?) (jump) + LoadPage ES,BX + mov AX,BX ;****** SAVE PAGE ********* +;;; mov ES,pagetabl+[BX] ; load list page's paragraph address + mov BL,ES:[SI].car_page ; load page number of car + cmp byte ptr ptype+[BX],LISTTYPE*2 ; does car point to list cell? + jne assoc_nl ; if not a list cell, jump + mov DI,ES:[SI].car ; load displacement pointer of car field + pushm ;****** REALLY SAVE PAGE**** + LoadPage ES,BX +;;; mov ES,pagetabl+[BX] + xor AX,AX + mov AL,ES:[DI].car_page ; copy car field into tmp_reg + mov tmp_page,AX + mov AX,ES:[DI].car + mov tmp_disp,AX + mov AX,offset tmp_reg + pushm ; push arguments to call + C_call sequal_p,,Load_ES ; compare equality of the two pointers + add SP,WORDINCR ; dump tmp_reg address + pop DX ; restore obj/dest register address + popm ; restore ES,SI registers + LoadPage ES,BX ;********** Restore Para Address ***** + cmp AX,0 ; were pointers equal? + jne assoc_t ; if equal, jump +assoc_nl: xor BX,BX ; clear high order byte of BX + mov BL,ES:[SI].cdr_page ; follow cdr field + mov SI,ES:[SI].cdr + cmp byte ptr s_break,0 ; has the shift-break key been depressed? + je assoc_lp ; if no shift-break, loop + jmp memq_sb ; if interrupt, jump to debugger support +; pointers "equal"-- return pointer to car field of current list cell +assoc_t: mov DI,DX ; copy destination register address to DI + mov AL,ES:[SI].car_page ; return cdr field of list cell + mov byte ptr [DI].C_page,AL + mov AX,ES:[SI].car + mov [DI].C_disp,AX + jmp next_PC ; return to interpreter +; end of search, or error detected-- return nil +assoc_er: +assoc_nf: mov DI,DX ; copy destination register address to DI + mov byte ptr [DI].C_page,NIL_PAGE*2 ; store nil pointer into + mov [DI].C_disp,NIL_DISP ; destination register + jmp next_PC ; return to interpreter + +var_int endp + +;************************************************************************ +;* Lookup Symbol is Assoc List * +;* * +;* Purpose: To search a linked list for a given pointer * +;* * +;* Description: The list to be searched has the following format: * +;* * +;* +--------+--------+ +--------+-------+ * +;* +-->|symbol->|value ->| +-->|symbol->|value->| * +;* | +--------+--------+ | +--------+-------+ * +;* | | * +;* +---+----+--------+ +---+----+--------+ * +;* | o | o----+----...----->| o | (nil) | * +;* +--------+--------+ +--------+--------+ * +;* * +;* The symbol portion of the list entries are compared against the * +;* search symbol for an identical match. When found, a pointer to * +;* the matched symbol's symbol-value entry is returned. If the * +;* symbol is not found, a value of nil is returned. * +;* * +;* Registers upon entry: AX - search symbol's displacement * +;* BX - page number of list to search * +;* DL - search symbol's page number * +;* SI - displacement within page number * +;* of list to search * +;* * +;* Registers on exit: BL - page number of cell whose car is the * +;* search symbol, or zero if not found * +;* DI - displacement of list cell found, or nil * +;* ES:[DI] - points to cell found * +;************************************************************************ + public lookup +lookup proc near +lookloop: + mov CX,BX ; Save Page number + LoadPage ES,BX ; Load Paragraph address of page + mov BL,ES:[SI].car_page ; load car of next list cell in the list + cmp byte ptr ptype+[BX],LISTTYPE*2 ; is car a list cell? + mov DI,ES:[SI].car + jne look_err ; if not a list cell, jump + LoadPage ES,BX +;;; mov ES,pagetabl+[BX] ; load paragraph address of its page + cmp AX,ES:[DI].car ; does car's disp match search symbol's? + jne look_nf ; if not, keep searching (jump) + cmp DL,ES:[DI].car_page ; does car's page match search symbol's? + je look_fnd ; if so, we've got a match (jump) +; no match-- continue through linked list +look_nf: mov BX,CX ; restore page number + LoadPage ES,BX + mov BL,ES:[SI].cdr_page ; load the cdr field + cmp byte ptr ptype+[BX],LISTTYPE*2 ; is cdr another list cell? + jne look_err ; if not, error(?) + mov SI,ES:[SI].cdr + cmp BX,0 ; is cdr nil? + jne lookloop ; if not, branch + xor DI,DI ; make BX:DI nil +look_fnd: ret ; return pointer to caller +; +look_err: xor BX,BX ; create a nil pointer to return + xor SI,SI + ret +lookup endp + +;************************************************************************ +;* C-callable Fluid Variable Lookup * +;* * +;* Purpose: To retrieve the fluid binding for a variable. * +;* * +;* Calling Sequence: stat = fluid_lookup(®) * +;* where ® - address of the register containing * +;* the symbol to be looked up. * +;* On exit, "reg" contains the * +;* current binding for the symbol, * +;* if found. * +;* stat - search status: TRUE=symbol found * +;* FALSE=symbol not found * +;* * +;* Note: If the call to "lookup" doesn't find the desired symbol, it * +;* will return a nil pointer. It is correct to always * +;* return the cdr of the pointer "lookup" returns, since * +;* the cdr of nil is itself nil-- a valid value. * +;************************************************************************ +fl_lk_ar struc + dw ? ; caller's BP + dw ? ; caller's ES + dw ? ; return address +fl_lk_rg dw ? ; register address +fl_lk_ar ends + + public fluid_lo +fluid_lo proc near + push ES ; save caller's ES + push BP ; and BP + mov BP,SP +; load pointer to search symbol in DL:AX + mov BX,[BP].fl_lk_rg ; load register address + mov AX,[BX].C_disp + mov DL,byte ptr [BX].C_page +; load pointer to search list (fluid environment) in ES:[SI] + mov BX,FNV_pag + mov SI,FNV_dis +;;; LoadPage ES,BX +;;; mov ES,pagetabl+[BX] +; search the fluid environment for the symbol + call lookup +; store "cdr" of returned cell into register + mov SI,[BP].fl_lk_rg + mov AL,ES:[DI].cdr_page + mov byte ptr [SI].C_page,AL + mov AX,ES:[DI].cdr + mov [SI].C_disp,AX +; set return code (BX=0 if symbol not found) and return + mov AX,BX + pop BP ; restore caller's BP + pop ES ; and ES + ret ; return to caller +fluid_lo endp + +prog ends + end + \ No newline at end of file diff --git a/sw_int.asm b/sw_int.asm new file mode 100644 index 0000000..d685d0a --- /dev/null +++ b/sw_int.asm @@ -0,0 +1,46 @@ + +DGROUP group data +data segment word public 'DATA' + assume DS:DGROUP +data ends + +PGROUP group prog +prog segment byte public 'PROG' + assume CS:PGROUP + public isw_int,fsw_int,tsw_int,ssw_int + +SWI_ARGS struc +OLDBP DW ? +RET_ADDR DW ? +INT_NUM DW ? +AX_ARG DW ? +BX_ARG DW ? +CX_ARG DW ? +DX_ARG DW ? +SWI_ARGS ends + +sw_int proc near +isw_int: +fsw_int: +tsw_int: +ssw_int: + push bp ; Save Base Pointer + mov bp,sp ; Update with Stack Pointer + + mov ax,[bp].INT_NUM ; Get interrupt number + mov cs:int_no,al ; Move to location in code + + mov ax,[bp].AX_ARG ; Load ax register with 1st arg + mov bx,[bp].BX_ARG ; Load bx register with 2nd arg + mov cx,[bp].CX_ARG ; Load cx register with 3rd arg + mov dx,[bp].DX_ARG ; Load dx register with 4th arg + + db 0CDh ; Byte code for INT instruction +int_no db 070h ; Byte code for interrupt number + pop bp + ret ; and go back to the caller. + +sw_int endp +prog ends + end + \ No newline at end of file diff --git a/version.h b/version.h new file mode 100644 index 0000000..96ee114 --- /dev/null +++ b/version.h @@ -0,0 +1,16 @@ +#ifdef REGMEM + #define VERSION "\n PC Scheme 3.03 07 June 88" +#endif + +#ifdef EXPMEM + #define VERSION "\n PC Scheme 3.03 Expanded Memory Version 07 June 88" +#endif + +#ifdef EXTMEM + #define VERSION "\n PC Scheme 3.03 Extended Memory Version 07 June 88" +#endif + +#ifdef PROMEM + #define VERSION "\n PC Scheme 4.0 Protected Memory Version 24 June 88" +#endif + \ No newline at end of file diff --git a/xli.asm b/xli.asm new file mode 100644 index 0000000..3b69433 --- /dev/null +++ b/xli.asm @@ -0,0 +1,1371 @@ +; =====> XLI.ASM +; PC Scheme External Language Interface (XLI) +; (c) 1987,1988 by Texas Instruments Incorporated -- all rights reserved +; Author: Bob Beal +; History: +; rb 3/20/87 - original +; rb 2/ 2/88 - check XLI ID; +; added external-program error return +; + + + page 84,120 + name PCSXLI + title PC Scheme External Language Interface + + include scheme.equ + include xli.equ + include xli.ref + include xli.mac + + subttl Group and Constant definitions + page +pgroup group prog +xgroup group progx +dgroup group data + + subttl Data segment definitions + page + +data segment para public 'DATA' + assume ds:dgroup + + public load_table,work_area,active_exe ;??? for debugging + +; Various tables +load_table dw N_EXE dup (0) ;PSP addresses (segment) +fb_table dd N_EXE dup (0) ;file block addresses (offset,segment) +pb_table dd N_EXE dup (0) ;parm block addresses (offset,segment) +state_table state N_EXE dup (<>) ;child's regs at point it called us +status_table label word ;records .EXE state (MSBy) and index (LSBy) +x = 0 + rept N_EXE + dw x +x = x+1 + endm + +; Parameter block for EXEC function request +zero equ $ ;a constant zero +exec_pblock dw 0 ;env@ (use Scheme's) + dw zero,seg zero ;cmd line@ (don't care) + dd -1 ;FCB@'s (don't care) + dd -1 + +; Working storage (during a given call to the external routine) + align 16,data +work_area label word ;for dealing with PCS data values +exe_name label byte ;a filename from XLI's control file + db PAD_SIZE*N_ARGS dup (0) ;during xesc, non-strings go here +; other information required during an xesc call +work_info xesc_struc <> ;general info +swap_table swap_struc N_ARGS dup (<>) ;records swap state for each XCALL arg +exe_name1 dw offset exe_name ;pointer into exe_name to filename.extension + ;(i.e. points past directory prefix) +bid_name dw 0 ;pointer into exe_name; used for bidding child +; the child currently active or being loaded +active_exe dw 0 ;(same format as status table) +; system .EXE information +sysflag db 0 ;0=user .EXE; 1=system .EXE + ;look for system .EXE's only in pcs-sysdir +pcs_exe db 'newtrig.exe',0 ;PCS system .EXE files +pcs_exe_len equ $-pcs_exe + +; State (context) information +; child's registers upon calling PCS +save_ax dw 0 ;actually, we ignore ax..di entries +save_bx dw 0 +save_cx dw 0 +save_dx dw 0 +save_si dw 0 +save_di dw 0 +save_ds dw 0 +save_es dw 0 +save_ss dw 0 +save_sp dw 0 +save_bp dw 0 +; our registers upon calling child +pcs_state state <> ;our state at point of calling child +; the SP just after the indirect call through "gate"; +; error recovery is done with: +; mov SP,gate_SP +; ret +; which returns to the instruction following the indirect call +gate_SP dw 0 + + +data ends + + + subttl Code segment: load_all + page + +; external variables + extrn ctl_file:word,pcs_sysd:word + extrn regs:word +; external routines + extrn alloc_fl:near,int2long:near,long2int:near,alloc_bl:near + extrn getbase:near + +progx segment para public 'PROGX' + assume cs:xgroup,ds:dgroup,es:dgroup,ss:dgroup + + public %xli_gate + public load_all,load_exe,bid_child,c2p_handler,c2p_terminate + public xesc1,unload_all,find_open_spot,table_search + public do_floarg,do_fixarg,do_bigarg,do_strarg + public do_floval,do_intval,do_TFval,do_strval + public unload_exe,unload_all,update_swap_table + + +; This routine is called when PCS first comes up. External programs are +; loaded first (by this file) and then the Scheme heap is allocated (initmem). +; Any errors encountered are ignored. If we run of memory, initmem +; should see it too and notify smain to abort. + +load_all proc +; First copy into exe_name buffer the pcs-sysdir name. + cld + push ds ;make ES=DS + pop es + mov di,pcs_sysd + mov cx,64 ;max length of pathname + mov al,0 + repne scasb ;look for eos character (=0) + jcxz la_5 ;jump if none + dec di +la_5: mov cx,di + sub cx,pcs_sysd ;get length of pcs-sysdir + ;without eos character + mov si,pcs_sysd + mov di,offset exe_name + rep movsb ;copy pcs-sysdir name (- eos) + ;into exe_name buffer + mov al,'\' ;append \ onto pcs-sysdir name + dec di + cmp [di],al ;is '\' last char of pcs-sysdir? + je la_7 ;yes; write it over itself + inc di ;no; move past end, then write +la_7: stosb + mov exe_name1,di ;exe_name1 points to next + ;open position in exe_name +; load system .EXE files + mov bx,ctl_file + cmp byte ptr [bx],'-' ;suppress loading system .EXE's? + jne sysload ;no + inc ctl_file ;yes, move past marker + jmp short userload ;and skip loading system .EXE's +sysload: mov si,offset pcs_exe ;get first system .EXE name + mov di,exe_name1 + mov cx,pcs_exe_len + rep movsb ;copy into buffer after + ;pcs-sysdir name + mov sysflag,1 ;set sysflag + call load_exe ;load the file +; open XLI control file +userload: mov sysflag,0 + dos_fr FR_OPEN,,,ctl_file,ds + mov bx,ax ;put handle in BX + jnc next_file ;jump if no open errors + jmp close1 ;can't open file, exit +; read in next filename off the control file and append it to +; the pcs-sysdir name +next_file: mov dx,exe_name1 ;init buffer @ +next_char: dos_fr FR_READ,bx,1,dx,ds ;read 1 character + jnc la_10 ;jump if no error, else + ;suddenly can't read control + ;file, close it and exit +close: dos_fr FR_CLOSE,bx +close1: ret + +la_10: cmp ax,0 ;at eof? + jz close ;yes, jump +; we've read a character + mov si,dx + cmp byte ptr [si],' ' ;blank? + je next_char ;yes, skip it + cmp byte ptr [si],0Dh ;carriage return? + je got_file ;yes, jump + cmp byte ptr [si],' ' ;control char? + jl next_char ;yes, skip it + inc dx ;point to next buffer position + jmp next_char +; we've read a complete filename, go load it +got_file: mov byte ptr [si],0 ;form ASCIIZ string + call load_exe ;bid it + jnc next_file ;jump if no errors + cmp ax,0 ;any open slots? + je close ;no, jump + cmp ax,2 ;file found? + je next_file ;no, jump + cmp ax,8 ;ran out of memory? + jne next_file ;no, jump; ignorable error + jmp close ;yes + +load_all endp + +; Given exe_name, this routine loads the child into any available open slot. +; On exit: +; success: carry clear +; failure: carry set +; AX = 0 : no open slots +; AX <> 0 : EXEC failure code +load_exe proc + push ax + push bx +; if we succeed, state=EXE_NONE + call find_open_spot ;this sets active_exe + mov ax,0 + jc le_exit ;no open slots +; set state=EXE_TSR for time between EXEC and TSR + load_index itself + mov bh,EXE_TSR + mov active_exe,bx + cmp sysflag,1 ;loading system .EXE? + je le_5 ;yes, look only in pcs-sysdir + mov ax,exe_name1 ;try current directory first + mov bid_name,ax + call bid_child + jnc le_10 ;bid succeeded, jump +le_5: mov ax,offset exe_name ;try again with pcs-sysdir prefix + mov bid_name,ax + call bid_child + jc le_exit ;bid failed, jump +; child is ready, set state=EXE_NORM +le_10: load_index itself + mov bh,EXE_NORM + mov ax,bx + load_index status_table + mov status_table[bx],ax + clc +le_exit: pop bx + pop ax + ret +load_exe endp + +;le_err: cmp ax,0 +; je le_exit ;it's not up, just exit +; cmp ax,8 +; jne fail1 +; mov ax,XLI_ERR_NO_MEMORY +; jmp xli_err_exit +;fail1: cmp ax,2 +; jne fail2 +; mov ax,XLI_ERR_NO_SUCH_FILE +; jmp xli_err_exit +;fail2: mov ax,XLI_ERR_BAD_EXEC +; jmp xli_err_exit +;le_err1: cmp xli_up,0 ;can't do usual error handling if +; ;system's not up yet +; je le_exit ;it's not up, just exit +; mov ax,XLI_ERR_NO_AVAILABLE_SLOTS +; jmp xli_err_exit + +; Given a filename in "exe_name", initialize it under XLI. +; The EXEC status is returned. +; Assume AX..DI,ES are destroyed; DS,SS,SP,BP are preserved. +bid_child proc + push ds ;save parent's state + push bp + save_parent + mov cs:stk_seg,ss + mov cs:stk_offset,sp + dos_fr FR_EXEC,,,bid_name,ds,ds + +; The following are external entry points accessible by the child. +biddbg: jmp tsr_done ; --- THE BIG 4 --- (not for child's use) + jmp c2p_handler ; --- THE BIG 4 --- for XCALL's + jmp c2p_terminate ; --- THE BIG 4 --- for child termination + +tsr_done: cli + mov ss,cs:stk_seg + mov sp,cs:stk_offset + sti + pop bp + pop ds + ret + +stk_seg dw 0 ;bootstrap parent's state after EXEC +stk_offset dw 0 ;from here + +bid_child endp + + subttl Code segment: Child->parent handler + page + +; On entry to this routine PCS is executing in the child's environment. +; The relevant stack entries at this point are: +; SS:SP (top) -> IP ;child's far return address +; CS +; length ;child's length; for TSR +; PSP@ ;child's PSP@ +; //// ;(the rest of the stack) + +c2p_handler label near + resume_parent + load_index itself + cmp bh,EXE_NORM ;normal call from child? + jne c2_10 ;no, jump; could be TSR + jmp normal ;yes, jump--rejoin xesc +c2_err: mov ax,XLI_ERR_SYNC_ERR + jmp xli_err_exit +c2_10: cmp bh,EXE_TSR ;first call from child? (before TSR) + jne c2_err ;no, jump + load_index state_table + lea bx,state_table[bx] + mov es,[bx].st_ss + mov bp,[bx].st_sp ;ES:BP is child's SS:SP + mov ax,es:[bp].cs_psp ;get child's PSP off its stack + load_index load_table + mov load_table[bx],ax ;save it + push ds ;-----> DS set to child's PSP + mov ds,ax + mov ax,ds:fb_ptr ;get file block @ + mov cx,ds:fb_ptr+2 + mov dx,ds:env_ptr ;get env block @ (seg addr) + pop ds ;<----- + load_index fb_table + mov word ptr fb_table[bx],ax ;save it + mov word ptr fb_table+2[bx],cx + push es ;tempsave child's SS:SP on stack + push bp + mov bp,ax + mov es,cx ;ES:BP is file block @ + mov ax,es:[bp].fb_pb + mov cx,es:[bp].fb_pb+2 ;get parm block @ + load_index pb_table + mov word ptr pb_table[bx],ax ;save it + mov word ptr pb_table+2[bx],cx + test word ptr es:[bp].fb_flags,FB_KEEPENV + ;keep child's env block? + jnz c2_20 ;yes, jump + dos_fr FR_RELMEM,,,,,dx ;no, release it for child +c2_20: pop bp + pop es + mov dx,es:[bp].cs_len ;get child's length off its stack +; we're ready to TSR the child + dos_fr FR_TSR,,,dx +; we don't drop through ----------------------------------------- + + + subttl Code segment: Child termination + page + +; After the child has performed its wrapup, it calls this routine +; to deallocate its memory and make its spot in the load table available. +c2p_terminate label near + mov ax,dgroup ;we needn't save child's context now + mov ds,ax + restore_parent + load_index load_table ;release the child + dos_fr FR_RELMEM,,,,,load_table[bx] + jc ct_err + load_index itself ;mark its spot as available + xor bh,bh + mov ax,bx + load_index status_table + mov status_table[bx],ax + jmp normal1 ;rejoin unload_exe +ct_err: mov ax,XLI_ERR_RELMEM + jmp xli_err_exit + + subttl Code segment: xesc + page + +; This is the handler for the "%xesc" opcode. +; +; On entry: +; AX = length of xesc call (= inst length - 1) +; ES:SI = pointer to bytecode containing the (reg# x 4) of +; the %xesc name string +; On exit: +; normal: the VM reg that contained the name string on entry +; will contain the page:offset of the return value; +; there may be side effects in strings that were arguments to %xesc +; BX = 0 (no errors) +; error: BX = error# + +xesc proc near +xesc1: cld + sub ax,2 ;adjust to #args *to %xesc* + ;(len, name are not args) + mov work_info.xs_nargs,ax ;save actual #args +; Get from register# (actually, reg x 4) to lookup string. + lods byte ptr es:[si] + mov bl,al + xor bh,bh ;BX is reg# x 4 of name string + mov work_info.xs_pc,si ;save bytecode@ + mov work_info.xs_pc+2,es + mov work_info.xs_rvreg,bx ;save reg# x 4; + ;return value goes here + lea bx,regs[bx] ;reg# x 4 -> VM reg @ + mov si,[bx].C_page + cmp ptype[si],STRTYPE*2 ;is it a string? + je xesc_5 ;yes, jump + cmp ptype[si],SYMTYPE*2 ;is it a symbol? + je xesc_3 ;yes, jump + mov ax,XLI_ERR_NAME_BAD_TYPE ;error: name not string, symbol + jmp xesc_err_exit +xesc_3: %LoadPage es,si ;page# in SI -> para# in ES + mov bp,[bx].C_disp ;ES:BP is symbol object @ + mov ax,es:[bp].sym_len ;get symbol object length + sub ax,sym_ovhd ;subtract symbol's overhead + add bp,sym_ovhd ;skip past overhead + jmp short xesc_9 +xesc_5: %LoadPage es,si ;page# in SI -> para# in ES + mov bp,[bx].C_disp ;ES:BP is string object @ + mov ax,es:[bp].str_len ;get string object length + cmp ax,0 ;is it positive? + jge xesc_8 ;yes, jump; normal string + add ax,str_ovhd*2 ;no, assume short string + ;rather than really long string + ;and make positive +xesc_8: sub ax,str_ovhd ;subtract string's overhead + add bp,str_ovhd ;skip past overhead +xesc_9: mov work_area.srch_slen,ax ;save length of string data + mov work_area.srch_sptr,bp ;save address of string data + mov work_area.srch_sptr+2,es +; Look for a match. + call table_search ;is there a match? + ;(sets active_exe if so) + jnc xesc_10 ;yes, jump + mov bx,work_info.xs_rvreg ;get the name + lea bx,regs[bx] + mov ax,XLI_ERR_NO_SUCH_NAME ;error: no such name loaded + jmp xesc_ext_err_exit ;use alternate error point + ;so name gets printed with + ;error message +xesc_10: mov dx,ax ;tempsave selector +; There was a match. +; Collect the info we'll need to guide us thru xesc call. + load_index fb_table + mov bp,word ptr fb_table[bx] + mov es,word ptr fb_table+2[bx] ;ES:BP is file block @ + mov ax,es:[bp].fb_id ;XLI ID + cmp ax,XLI_ID + je xesc_15 + mov ax,XLI_ERR_BAD_VERSION + jmp xesc_err_exit +xesc_15: mov ax,es:[bp].fb_flags ;flags + mov work_info.xs_flags,ax + load_index pb_table + mov bp,word ptr pb_table[bx] + mov es,word ptr pb_table+2[bx] ;ES:BP is parm block @ + mov work_info.xs_pb_segment,es ;parm block's segment address + lea ax,es:[bp].pb_rv + mov work_info.xs_rvptr,ax + mov work_info.xs_rvptr+2,es ;return value's address + mov es:[bp].pb_rv,0 ;zero out return value + mov es:[bp].pb_rv+2,0 + mov es:[bp].pb_rv+4,0 + mov es:[bp].pb_rv+6,0 + mov es:[bp].pb_rvtype,SWI_TF ;set ret value's type to T/F + mov es:[bp].pb_ss,0 ;zero out special service + add ax,8 + mov work_info.xs_args,ax ;first arg's address + mov work_info.xs_args+2,es + mov work_info.xs_local,offset work_area ;work area address + mov work_info.xs_local+2,seg work_area +; Begin initializing child's parameter block. + mov es:[bp].pb_select,dx ;store selector into parm block + mov work_info.xs_select,dx +; Move the xesc arguments to their places for the xesc call. +; mov cx,work_info.xs_nargs ;CX is #args +;xesc_20: cmp cx,0 ;any left? +; jcxz xesc_50 ;no, jump + mov cx,0 ;CX is current arg# +xesc_20: cmp cx,work_info.xs_nargs ;any left? + je xesc_50 ;no, jump + push cx ;tempsave current arg# + mov si,work_info.xs_pc + mov es,work_info.xs_pc+2 ;ES:SI is bytecode@ + lods byte ptr es:[si] + mov work_info.xs_pc,si ;save next bytecode @ + mov bl,al + xor bh,bh ;BX is reg# x 4 +; Put the reg# and current arg @ into swap table + mov ax,bx + xchg bx,cx ;BX is current arg# + shl bx,1 + shl bx,1 ;make index into swap table + mov word ptr swap_table[bx].sw_reg,ax ;save VM reg# x 4 + mov ax,work_info.xs_args + mov word ptr swap_table[bx].sw_offset,ax ;save arg@ + mov bx,cx ;restore reg# x 4 +; Dispatch on argument type + lea bx,regs[bx] ;BX is VM reg @ + mov di,[bx].C_page ;get its page# + mov di,ptype[di] ;and its type +; push cx + call cs:word ptr do_arg[di] ;handle one type of object + add work_info.xs_local,PAD_SIZE ;incr XLI-local ptr + ;(maintain alignment) + pop cx ;restore current arg# +; dec cx + inc cx + jmp xesc_20 + +; Everything's ready. Call the child. +xesc_50: call update_swap_table + call_child 1 + +; We're back with a return value--unless it's a special service call. +normal: cld + load_index pb_table + mov bp,word ptr pb_table[bx] + mov es,word ptr pb_table+2[bx] ;ES:BP is parm block @ + cmp es:[bp].pb_ss,0 ;any special services? + je xesc_60 ;no, jump + call ssr ;do special service and + jmp xesc_50 ;return immediately back + ;across the interface +; Now we're really back with the return value +xesc_60: mov di,es:[bp].pb_rvtype + mov work_area.xs_rvtype,di ;return value's type + cmp di,RV_ERR ;external-pgm error return? + jne xesc_65 ;no, jump + mov bp,work_info.xs_rvptr + mov es,work_info.xs_rvptr+2 ;ES:BP points to return value + ;(external-pgm error message) + call cs:word ptr do_val[SWI_STR*2] ;build string + mov bx,work_info.xs_rvreg + lea bx,regs[bx] ;BX=addr of reg with error string + mov ax,XLI_ERR_EXTERNAL_ERROR ;AX=XLI error code + jmp short xesc_ext_err_exit + +xesc_65: cmp di,N_RV ;return value out of range? + jb xesc_70 ;no, jump + mov ax,XLI_ERR_VALUE_BAD_TYPE + jmp xesc_err_exit +xesc_70: shl di,1 + mov bp,work_info.xs_rvptr + mov es,work_info.xs_rvptr+2 ;ES:BP point to return value + call cs:word ptr do_val[di] ;handle one type of return value + lea bx,nil_reg ;CX says "nil irritant" + mov ax,0 ;BX=0 says no errors + ret + +; This file's error exit processing. Reset the stack so that we return +; immediately to the gate. BX should be set with an error code before +; jumping here. +xli_err_exit: +xesc_err_exit: ;AX contains error# + lea bx,nil_reg ;BX is "nil irritant" +; Another exit label. This allows both AX (XLI error code) and BX +; (the address of the VM register with the "irritant") to be set beforehand. +xli_ext_err_exit: +xesc_ext_err_exit: + mov sp,gate_sp ;return to gate + ret + + +;; Jump tables +; indexed by argument type (standard PCS type tag) +do_arg dw do_lstarg ;0=list (#f only) + dw do_fixarg ;1=fixnum + dw do_floarg ;2=flonum + dw do_bigarg ;3=bignum + dw do_symarg ;4=symbol (#t only) + dw do_strarg ;5=string + dw do_errarg ;6 the rest we don't care about + dw do_errarg ;7 + dw do_errarg ;8 + dw do_errarg ;9 + dw do_errarg ;10 + dw do_errarg ;11 + dw do_errarg ;12 + dw do_errarg ;13 + dw do_errarg ;14 + dw do_errarg ;15 + +; indexed by value type (SW-INT return types) +do_val dw do_intval ;0=integer + dw do_TFval ;1=true/false + dw do_strval ;2=string + dw do_floval ;3=flonum + +xesc endp + + subttl Code segment: Copy arguments into place for child + page + +; On entry to all the argument handler routines: +; BX = pointer to VM reg with page:offset of Scheme object + +do_floarg proc near + mov si,[bx].C_page ;get object's page# + %LoadPage es,si ;swap it in + mov si,[bx].C_disp ;ES:SI is Scheme object @ + test work_info.xs_flags,FB_NEAR ;near flag on? + jz do_flo10 ;no, jump +; Set up destination address + ; near + mov cx,work_info.xs_args ;dest is in child + mov dx,work_info.xs_args+2 + mov work_info.xs_dest,cx + mov work_info.xs_dest+2,dx + jmp short do_flo20 + ; far +do_flo10: mov cx,work_info.xs_local ;dest is in XLI-local area + mov dx,work_info.xs_local+2 + mov work_info.xs_dest,cx + mov work_info.xs_dest+2,dx +; Copy the flonum data +do_flo20: inc si ;incr past tag + mov di,work_info.xs_dest + push ds ;tempsave DS around copy + push es + mov es,work_info.xs_dest+2 ;ES:DI points to dest + pop ds ;DS:SI is Scheme object @ + mov cx,8 + rep movsb + pop ds ;restore our DS + test work_info.xs_flags,FB_NEAR ;near flag on? + jz do_flo30 ;no, jump +; Copy pointer to data + ; near (no copy needed--data is in child's space) + mov cx,8 ;incr arg@ past copied data + jmp short do_flo32 + ; far (pointer in child points to data in XLI space) +do_flo30: sub di,8 ;back up dest @ + mov cx,di + mov dx,es + mov bp,work_info.xs_args + mov es,work_info.xs_args+2 ;ES:BP points to arg position + mov es:[bp],cx + mov es:[bp]+2,dx ;copy pointer there +; Increment arg pointer by an appropriate amount. + mov cx,4 ;incr arg@ past copied ptr +do_flo32: test work_info.xs_flags,FB_PAD ;pad flag on? + jz do_flo35 ;no, skip + mov cx,PAD_SIZE +do_flo35: add work_info.xs_args,cx +do_flo40: ret +do_floarg endp + +do_bigarg proc near + mov si,[bx].C_page ;get object's page# + %LoadPage es,si ;swap it in + mov si,[bx].C_disp ;ES:SI is Scheme object @ +; Stage the conversion to longint in XLI space. + mov bp,sp + push bx ;push VM reg@ + push work_info.xs_local ;push local buffer@ + mov work_info.C_fn,offset pgroup:int2long + call far ptr far_C + mov sp,bp + cmp ax,0 ;did bignum convert OK? + je do_big5 ;yes, jump + mov ax,XLI_ERR_BIG_TO_32_BITS ;error: bignum too big + ;to become longint + jmp xesc_err_exit +do_big5: test work_info.xs_flags,FB_NEAR ;near flag on? + jz do_big20 ;no, jump + ; near (copy longint to child's space) + mov bp,work_info.xs_local + mov es,work_info.xs_local+2 ;ES:BP points to XLI-local longint + mov ax,es:[bp] ;move longint to regs + mov dx,es:[bp]+2 + mov bp,work_info.xs_args + mov es,work_info.xs_args+2 ;ES:BP points to dest + mov es:[bp],ax ;copy LSBy to child + mov cx,2 + test work_info.xs_flags,FB_INT ;is 16-bit integer flag on? + jz do_big15 ;no, jump + ; is the longint small enough for an int? + cmp dx,0 ;DX should be either + ;all 0's or all 1's + je do_big32 ;we can safely truncate + xor dx,0FFFFh ;complement DX + cmp dx,0 ;try again + je do_big32 ;we can safely truncate + mov ax,XLI_ERR_BIG_TO_16_BITS ;error: bignum too big + ;to become int + jmp xesc_err_exit +do_big15: mov es:[bp]+2,dx ;copy MSBy to child + mov cx,4 + jmp short do_big32 + ; far (pointer in child points to data in XLI-local space) +do_big20: mov ax,work_info.xs_local ;move ptr to longint to regs + mov dx,work_info.xs_local+2 +; Copy either the longint or a pointer to it. + mov bp,work_info.xs_args + mov es,work_info.xs_args+2 ;ES:BP points to dest + mov es:[bp],ax ;copy to child + mov es:[bp]+2,dx + mov cx,4 ;incr arg@ past longint + ;or pointer to longint +; Increment arg pointer by an appropriate amount. +do_big32: test work_info.xs_flags,FB_PAD ;pad flag on? + jz do_big35 ;no, skip + mov cx,PAD_SIZE +do_big35: add work_info.xs_args,cx +do_big40: ret +do_bigarg endp + +do_fixarg proc near +; Stage the conversion to int in XLI space + mov ax,[bx].C_disp ;get the fixnum data + shl ax,1 ;deal with sign bit + sar ax,1 ;AX is 16-bit signed int +; True and false are treated as the numbers 1 and 0, respectively. +; Boolean-argument processing merges into integer processing at this point. +do_log: cwd ;DX:AX is 32-bit signed int +; Copy the int data to the proper place + mov bp,work_info.xs_args + mov es,work_info.xs_args+2 ;ES:BP points to dest + test work_info.xs_flags,FB_NEAR ;near flag on? + jz do_fix20 ;no, jump + ; near (copy int to child's space) + mov es:[bp],ax ;copy int to child + mov cx,2 ;incr arg@ past int + test work_info.xs_flags,FB_INT ;is 16-bit integer flag on? + jnz do_fix30 ;yes, jump + mov es:[bp]+2,dx ;no, copy high order 16 bits + mov cx,4 ;incr arg@ past longint + jmp short do_fix30 + ; far (pointer in child points to data in XLI-local space) +do_fix20: mov bx,work_info.xs_local + mov [bx],ax + mov [bx]+2,dx + mov ax,work_info.xs_local ;move far ptr to int + ;or longint to child + mov cx,work_info.xs_local+2 + mov es:[bp],ax + mov es:[bp]+2,cx + mov cx,4 ;incr arg@ past ptr to int +; Increment arg pointer by an appropriate amount +do_fix30: test work_info.xs_flags,FB_PAD ;pad flag on? + jz do_fix35 ;no, skip + mov cx,PAD_SIZE +do_fix35: add work_info.xs_args,cx +do_fix40: ret +do_fixarg endp + +do_lstarg proc near ;looking for false only + cmp [bx].C_page,NIL_PAGE*2 + jne do_xxerr + mov ax,0 + jmp do_log +do_lstarg endp + +do_xxerr: jmp do_errarg ;conditional jumps + ;are too short + +do_symarg proc near ;looking for true only + cmp [bx].C_page,T_PAGE*2 + jne do_xxerr + cmp [bx].C_disp,T_DISP + jne do_xxerr + mov ax,1 + jmp do_log +do_symarg endp + +do_strarg proc near + mov si,[bx].C_page + %LoadPage es,si ;load string into memory + mov si,[bx].C_disp ;ES:SI is Scheme object @ + test work_info.xs_flags,FB_NEAR ;near flag on? + jz do_str10 ;no, jump + ; near (can't copy string because we don't have its address-- + ; put nil address into parm block) + mov bp,work_info.xs_args + mov es,work_info.xs_args+2 ;ES:BP is arg @ + mov word ptr es:[bp],0 + mov cx,2 + jmp short do_str60 + ; far (we can copy the string's address, but need to check + ; on earlier strings' swap status) +do_str10: + mov ax,si + add ax,STR_OVHD + mov dx,es ;DX:AX is string data @ + mov bp,work_info.xs_args + mov es,work_info.xs_args+2 ;ES:BP is arg @ + mov es:[bp],ax + mov es:[bp]+2,dx + mov cx,4 +; Increment arg pointer by an appropriate amount +do_str60: test work_info.xs_flags,FB_PAD ;padding on? + jz do_str65 ;no, jump + mov cx,PAD_SIZE +do_str65: add work_info.xs_args,cx + ret +do_strarg endp + +do_errarg proc near + mov ax,XLI_ERR_ARGN_BAD_TYPE + jmp xesc_err_exit +do_errarg endp + + subttl Code segment: Copy return value back into Scheme + page + +; On entry to all the value handler routines: +; ES:BP = pointer to return value + +do_floval proc near + test work_info.xs_flags,FB_NEAR ;is near flag on? + jnz do_flv10 ;yes, jump + ; far + mov ax,es:[bp] ;get ptr to number + mov dx,es:[bp]+2 + mov bp,ax + mov es,dx ;ES:BP points to number + ; near +do_flv10: mov dx,es:[bp]+6 ;get double in registers + mov cx,es:[bp]+4 + mov bx,es:[bp]+2 + mov ax,es:[bp] + mov bp,sp ;get BP set for C call + push dx ;push double + push cx + push bx + push ax + mov bx,work_info.xs_rvreg ;push return value VM reg@ + lea bx,regs[bx] +; lea bx,reg1 ;temporary + push bx + mov work_info.C_fn,offset pgroup:alloc_fl + call far ptr far_C ;C double -> PCS flonum + mov sp,bp ;pop C args + ret +do_floval endp + +do_TFval proc near + mov cx,0 + mov ax,es:[bp] ;get value + or ax,es:[bp]+2 ;all bytes must = 0 to be nil + or ax,es:[bp]+4 + or ax,es:[bp]+6 + jz do_TF10 ;yes (false object) + mov ax,T_DISP ;no (true object) + mov cx,T_PAGE*2 +do_TF10: + mov bx,work_info.xs_rvreg ;push return value VM reg@ + lea bx,regs[bx] +; lea bx,reg1 ;temporary + mov [bx].C_disp,ax + mov [bx].C_page,cx + ret +do_TFval endp + +do_intval proc near + test work_info.xs_flags,FB_NEAR ;near flag on? + jnz do_int10 ;yes, jump + ; far + mov ax,es:[bp] ;get ptr to number + mov dx,es:[bp]+2 + mov bp,ax + mov es,dx ;ES:BP points to number + ; near +do_int10: mov ax,es:[bp] ;get number + mov dx,es:[bp]+2 + test work_info.xs_flags,FB_INT ;16-bit integer flag on? + jz do_int20 ;no, jump + cwd ;yes, propagate sign +do_int20: mov bp,sp ;get BP set for C call + push dx ;push longint + push ax + mov bx,work_info.xs_rvreg ;push return value VM reg@ + lea bx,regs[bx] +; lea bx,reg1 ;temporary + push bx + mov work_info.C_fn,offset pgroup:long2int + call far ptr far_C ;C longint -> PCS integer + ;(bignum or fixnum) + mov sp,bp ;pop C args + ret +do_intval endp + +do_strval proc near +; allocate the space for the return value string object + mov di,2 ;DI=offset of length in + ;return value field (near) + test work_info.xs_flags,FB_NEAR ;is near flag on? + jnz do_stv10 ;yes, jump + mov di,4 ;different offset for far +do_stv10: mov cx,es:[bp][di] ;get string's length + mov bx,16380 ;BX is max string length + cmp cx,bx ;is CX short enough? + jbe do_stv15 ;yes, jump + mov cx,bx ;no, truncate at max +do_stv15: push cx ;tempsave length + mov bp,sp ;get BP set for C call + push cx ;push length + mov ax,STRTYPE + push ax ;push type + mov bx,work_info.xs_rvreg + lea bx,regs[bx] + push bx ;push return value VM reg @ + mov work_info.C_fn,offset pgroup:alloc_bl + call far ptr far_C ;allocate string object; + ;"alloc_block" takes care + ;of overhead matters + mov sp,bp ;pop C args + pop cx ;restore length + mov bx,work_info.xs_rvreg + lea bx,regs[bx] ;BX is return value VM reg @ + mov di,[bx].C_disp + mov es,[bx].C_page + %LoadPage es,es ;ES:DI is dest object @ + add di,3 ;skip past string's overhead +; copy string data into string object + push es ;tempsave ES + mov si,work_info.xs_rvptr + mov es,work_info.xs_rvptr+2 ;ES:SI points to return value + ;field in parameter block + mov ax,es:[si] + mov dx,work_info.xs_pb_segment ;DX:AX is src string @ (near) + test work_info.xs_flags,FB_NEAR ;is near flag on? + jnz do_stv50 ;yes, jump + mov dx,es:[si]+2 ;DX:AX is src string @ (far) +do_stv50: pop es ;restore ES + push ds ;tempsave our DS + mov si,ax ;ES:DI is dest string @ + mov ds,dx ;DS:SI is src string @ + rep movsb ;copy string + pop ds ;restore our DS + ret +do_strval endp + +do_errval proc near + mov ax,XLI_ERR_VALUE_BAD_TYPE + jmp xesc_err_exit +do_errval endp + + subttl Code segment: Special Services + page + +; On entry, ES:BP is parm block pointer. + +ssr proc near + mov bx,es:[bp].pb_ss ;get dispatch number + cmp bx,SS_SWAP + je ss1 + jne ss_exit ;note we don't fall thru + +ss_normal_exit: + load_index pb_table + mov bp,word ptr pb_table[bx] + mov es,word ptr pb_table[bx]+2 + mov es:[bp].pb_ss,0 ;clear ss field for normal exit +ss_exit: ret + +; the conditional jumps can't jump far enough, hence this table +ss1: jmp ssr_swap + +; "Swap" special service + +ssr_swap: mov bx,es:[bp].pb_ss_args ;get arg# + mov cx,es:[bp].pb_ss_args+2 ;get dest. length + shl bx,1 + shl bx,1 + push bx ;tempsave index into swap table + test work_info.xs_flags,FB_NEAR ;is near flag on? + jnz ss_10 ;yes, jump + ; + ; Far ------------------- + ; + ; ss_args+0: swap table index corr. to arg# (already in BX) + ; + ; ss returns: + ; in ss_args+0: true length of string + ; in pb args: far @ to string + ; + mov bx,word ptr swap_table[bx].sw_reg ;BX is reg# x 4 + lea bx,regs[bx] ;BX is reg@ + mov si,[bx].C_page ;get object's page# + %LoadPage es,si ;load object into memory + mov si,[bx].C_disp ;ES:SI is string object @ + inc si ;skip over tag + mov ax,es:[si] ;get string's length + inc si ;skip over length + inc si + cmp ax,0 ;a short string? + jge ss_5 ;no, jump + add ax,str_ovhd*2 ;yes +ss_5: sub ax,str_ovhd ;subtract off overhead + mov di,es ;DI:SI is string data @ + mov es,work_info.xs_pb_segment ;ES:BP is parameter block @ + mov es:[bp].pb_ss_args,ax ;put string length in ss_args + pop bx ;restore swap table index + mov bp,word ptr swap_table[bx].sw_offset ;ES:BP points to this arg's + ;location in parameter block + mov es:[bp],si ;put far @ in parm block + mov es:[bp]+2,di + jmp ss_normal_exit + ; + ; Near ------------------- + ; + ; ss_args+0: swap table index corr. to arg# (already in BX) + ; +2: length (already in CX) + ; +4: near ptr + ; + ; ss returns: + ; in ss_args+0: length used in copying + ; in pb args: near @ to string + ; +ss_10: mov ax,es:[bp].pb_ss_args+4 ;get dest @ + mov work_info.xs_dest,ax + mov ax,work_info.xs_pb_segment + mov work_info.xs_dest+2,ax + mov bx,word ptr swap_table[bx].sw_reg ;get reg# x 4 corr. to arg + lea bx,regs[bx] ;BX is reg@ + mov si,[bx].C_page + %LoadPage es,si ;load object into memory + mov si,[bx].C_disp ;ES:SI is string object @ + inc si ;skip over tag + mov ax,es:[si] ;get string's length + inc si ;skip over length + inc si + cmp ax,0 ;a short string? + jge ss_15 ;no, jump + add ax,str_ovhd*2 ;yes +ss_15: sub ax,str_ovhd ;subtract off overhead + cmp ax,cx ;string len >= buffer len? + jae ss_20 ;yes, jump + mov cx,ax ;CX is #chars to copy +ss_20: push ds ;tempsave our DS + push es + mov di,work_info.xs_dest + mov es,work_info.xs_dest+2 ;ES:DI is dest @ + pop ds ;DS:SI is src @ + rep movsb ;copy string + pop ds ;restore our DS + load_index pb_table + mov bp,word ptr pb_table[bx] + mov es,word ptr pb_table[bx]+2 ;ES:BP is parm block @ + mov es:[bp].pb_ss_args,ax ;put #chars copied in ss_args + pop bx ;restore swap table index + mov bp,word ptr swap_table[bx].sw_offset ;ES:BP points to this arg's + ;location in parameter block + mov ax,work_info.xs_dest + mov es:[bp],ax ;put near @ in parm block + jmp ss_normal_exit + +ssr endp + + subttl Code segment: update_swap_table + page + +update_swap_table proc near +; for small models, PCS may indeed be swapping, but we don't care, as data +; is copied to the external program on its first reference and +; remains always available to the program since the pointer in the parm block +; points into the program's own space, not PCS's + test work_info.xs_flags,FB_NEAR ;is near flag on? + jnz ust_exit ;yes, exit + mov cx,0 ;CX is argument counter +ust_10: cmp cx,work_info.xs_nargs + jge ust_exit + mov bx,cx + shl bx,1 + shl bx,1 ;BX is swap table index + push bx ;tempsave index + mov bx,word ptr swap_table[bx].sw_reg ;get reg# x 4 of argument + lea bx,regs[bx] ;BX is reg@ + mov di,[bx].C_page ;get object's page# + mov di,ptype[di] ;then its type + cmp di,STRTYPE*2 ;is it a string? + je ust_40 ;yes, jump + pop bx ;no, discard index +ust_30: inc cx ;incr to next argument + jmp ust_10 +ust_40: mov ax,[bx].C_page ;get page# + mov bp,sp ;set up BP for calling C + push ax ;push page# + mov work_info.C_fn,offset pgroup:getbase ;this routine's not in + ;C but does use its calling + ;conventions + call far ptr far_C + mov sp,bp ;pop C args + pop bx ;restore swap table index + ; If carry is clear, the argument is in memory already. + ; The address in the parm block should be OK since an object + ; coming into memory has its address updated at the time of the + ; swap. Swapping does not cause a GC, so GC's shouldn't relocate + ; an address. That leaves zeroing the addresses of objects + ; that were swapped out. + jnc ust_30 ;object's in memory, jump + ; Carry set means object is swapped out. Zero the argument's + ; pointer in the parm block. + mov bp,word ptr swap_table[bx].sw_offset + mov es,work_info.xs_pb_segment ;ES:BP points to this arg's + ;location in the parm block + mov word ptr es:[bp],0 ;zero offset part of pointer + mov word ptr es:[bp]+2,0 ;zero segment part of pointer + jmp ust_30 +; +ust_exit: ret + +update_swap_table endp + + + subttl Code segment: unload_exe + page + +; Given active_exe, release it from memory and make its spot available again. +unload_exe proc near + load_index state_table + mov es,word ptr state_table[bx].st_ss + mov bp,word ptr state_table[bx].st_sp ;ES:BP is child's SS:SP + mov es:[bp].cs_psp,0 ;set PSP@ to 0, our signal + ;to child to wrap things up + call_child 2 ;call child one last time +normal1: ret +unload_exe endp + + + subttl Code segment: unload_all + page + +; This routine is called during PCS termination. It notifies each +; child to do any wrapup, then the child will do its final call to us, +; where we release it. + +unload_all proc near + mov active_exe,0 +ua_10: cmp active_exe,N_EXE ;looked at all entries? + je ua_exit ;yes, jump + load_index status_table + mov bx,status_table[bx] + cmp bh,EXE_NONE ;is slot empty? + jne ua_20 ;no, jump +ua_15: inc active_exe ;incr to next entry + jmp ua_10 +ua_20: call unload_exe ;deallocate entry + jmp ua_15 +ua_exit: ret +unload_all endp + + subttl Code segment: table_search + page + +; We need to find a matching string. From it we'll know +; which child has it and what value it maps to. +; On entrance: +; work_area.srch_sptr is the seg:offset of the Scheme string (data proper) +; work_area.slen is the string's length +; On exit: +; if success: AX = selector value +; active_exe = xxnnh, where n is the child +; carry clear +; if fail: carry set +; AX..DI,ES,BP are destroyed. + +table_search proc near + cld ;to be safe + mov work_area.srch_exe,0 +ts_10: cmp work_area.srch_exe,N_EXE ;looked at them all? + jne ts_15 ;no, jump +; No child had a match. Return with carry set. + stc + jmp ts_exit +ts_15: mov bx,work_area.srch_exe + mov active_exe,bx + load_index status_table + mov ax,status_table[bx] + cmp ah,0 ;is this an open spot? + jne ts_20 ;no, jump +ts_next: inc work_area.srch_exe ;increment to next spot + jmp short ts_10 +; We have a loaded file. Figure out where its lookup table is. +ts_20: load_index fb_table + mov bp,word ptr fb_table[bx] + mov es,word ptr fb_table+2[bx] ;ES:BP is file block @ + mov ax,es:[bp].fb_lut + mov dx,es:[bp].fb_lut+2 + mov di,ax + mov es,dx ;ES:DI is lookup table @ + mov ah,0 ;AH will be selector value + mov al,'/' ;AL is name delimiter +; Find the next name in the lookup table. +ts_30: cmp byte ptr es:[di],al ;looking at last delimiter? + je ts_next ;yes, jump + mov si,di ;SI points at current name + mov cx,0FFh + repne scasb ;look for name delimiter + jcxz ts_next ;jump, should've found it by now + mov dx,di ;DI, DX point at next name + mov cx,di + sub cx,si + dec cx ;CX is length of name in table + cmp work_area.srch_slen,cx ;are lengths equal? + jne ts_40 ;no, jump +; We matched lengths. See if the strings themselves match. + mov di,si ;get current name @ back in DI + push ds ;tempsave our DS + mov si,work_area.srch_sptr + mov ds,work_area.srch_sptr+2 ;DS:SI is Scheme string @ + repe cmpsb + pop ds ;restore our DS + je ts_match ;jump if match +; The current table name didn't match. +ts_40: inc ah ;increment selector value + mov di,dx ;restore next name @ to DI + jmp ts_30 +; We matched. Active_exe has child#, replace it with the corr. status value. +; Calculate the selector value (0-based) of the name and return it in AX. +; Clear carry. +ts_match: mov al,ah + xor ah,ah + load_index status_table + mov bx,status_table[bx] + mov active_exe,bx + clc +ts_exit: ret +table_search endp + + subttl Code segment: find_open_spot + page + +; Find an open spot in the load_table. Clear carry and set the LSBy of +; active_exe with the child# if we succeeded, else set carry. +find_open_spot proc near + push bx + push cx + mov cx,N_EXE + mov bx,0 +fi_loop: cmp byte ptr status_table[bx]+1,EXE_NONE + je fi_found + inc bx + inc bx + dec cx + cmp cx,0 + jne fi_loop + stc ;set carry if no available entries + jmp short fi_exit +fi_found: mov bx,N_EXE + sub bx,cx + mov active_exe,bx + clc ;an open entry: clear carry, set active_exe +fi_exit: pop cx + pop bx + ret +find_open_spot endp + + subttl Far/near linkage to XLI + page + +; Near linkage + +; All other routines in this file are accessed through this one. +; On entry, BX contains an index into a jump table of routines to execute. +%xli_gate proc far + shl bx,1 ;get index on word boundary + mov gate_sp,sp + sub gate_sp,2 +; We adjusted the SP for the return address which the call in the next +; instruction will put on the stack. +; Error recovery by nested routines is done by restoring this SP value and +; then returning, which will bring them back to just after the call. + call cs:gate[bx] + ret + +; jump table +gate dw load_all,xesc,unload_all + +%xli_gate endp + + subttl Debugging XLI from PCS + page + +; If PCS is run under DEBUG, executing (%xli-debug <0 or 1>) will +; execute the following code, which either installs an INT 3 (=1) or NOPs (=0). +; When INT 3 is executed, DEBUG is called. This provides a way for +; writers of external routines to get a hook at execution time into +; their code for debugging. Also, the value returned in AX is the PROGX offset +; of the jumps accessed from the external program. + +; Registers destroyed: AX + +%xlidbg proc far + or ax,ax + jz dbgoff + mov al,cs:dbgint ;install INT 3 instruction + mov xlidbg1,al + mov al,cs:dbgint+1 + mov xlidbg1+1,al + jmp short dbgexit +dbgoff: mov al,cs:dbgnop ;install 2 NOP instructions + mov xlidbg1,al + mov xlidbg1+1,al +dbgexit: mov ax,offset biddbg ;return address of jump table + ;following EXEC of child + ret + +; data for above routine +dbgint label byte + int 3 ;INT 3 instruction +dbgnop label byte + nop ;NOP instruction + +%xlidbg endp + +progx ends + + +; Far linkage *to* XLI + +prog segment byte public 'PROG' + assume cs:pgroup + + public xli_init,xli_xesc,xli_term + +; We preserve DS,ES,BP. AX..DI are destroyed. +xli_init proc near + mov bx,0 +xli_10: push bp ;we use ES:BP a lot + push es + call %xli_gate ;cross over into PROGX segment + pop es + pop bp + ret +xli_xesc: mov bx,1 + jmp xli_10 +xli_term: mov bx,2 + jmp xli_10 +xli_init endp + +; Far linkage *from* XLI +; (all the memory allocation routines are written in C). +; The caller of this should have set BP from SP before pushing the C args, +; then restore SP from BP afterwards to remove them from the stack. +; We don't preserve ES across the call. + +far_C proc far + push ds ;C likes ES=DS + pop es + pop work_info.C_retadr ;get far @ off stack so C sees its args + pop work_info.C_retadr+2 + call [work_info.C_fn] + push work_info.C_retadr+2 + push work_info.C_retadr + ret ;C returns with return value in AX..DX +far_C endp + +; Far linkage to XLI debug hook + +; stack: +; saved BP +; return address (near call) +; arg (0=turn off, 1=turn on debug) + +; AX,BX returns PROGX offset of the jump table following the EXEC of the child. +; This should be the same offset value as in the DOS terminate address vector +; in the child's PSP. + + public xlidbg + +xlidbg proc near + push bp + mov bp,sp ;after this instruction, stack matches comments + mov ax,[bp]+4 + call %xlidbg + pop bp + ret +xlidbg endp + +prog ends + end + \ No newline at end of file diff --git a/xli.equ b/xli.equ new file mode 100644 index 0000000..cab7cdf --- /dev/null +++ b/xli.equ @@ -0,0 +1,70 @@ + +; XLI constants +; note: if N_EXE is ever made larger, examine macro "load_index" also +XLI_ID equ 4252h ;XLI version number + ;(PCS 3.0, 3.02 XLI id = 4252) +N_EXE equ 10 ;no. of .EXE files allowed +N_ARGS equ 16 ;no. of xesc args allowed +N_RV equ 4 ;no. of return values + ;same as for SW-INT: 0-3, with same meaning +SWI_TF equ 1 ;SW-INT true/false return value +SWI_STR equ 2 ;SW-INT string return value +RV_ERR equ 10 ;error return value code +PAD_SIZE equ 8 ;max size of 1 elementary data type, + ;which is size of 1 elt in work_area + ;(flonum/double) + +; XLI errors +XLI_ERR_UNKNOWN_LENGTH equ 1 ;fatal error +XLI_ERR_NAME_BAD_TYPE equ 2 +;XLI_ERR_MISMATCHED_LENGTH equ 3 +XLI_ERR_ARGN_BAD_TYPE equ 4 +XLI_ERR_VALUE_BAD_TYPE equ 5 +XLI_ERR_NO_SUCH_NAME equ 6 +XLI_ERR_BIG_TO_32_BITS equ 7 +XLI_ERR_SYNC_ERR equ 8 +XLI_ERR_RELMEM equ 9 +XLI_ERR_NO_MEMORY equ 10 +XLI_ERR_BAD_EXEC equ 11 +XLI_ERR_NO_AVAILABLE_SLOTS equ 12 +XLI_ERR_NO_SUCH_FILE equ 13 +XLI_ERR_BIG_TO_16_BITS equ 14 +XLI_ERR_BAD_VERSION equ 15 +XLI_ERR_EXTERNAL_ERROR equ 16 + +; DOS function requests +FR_TSR equ 3100h ;TSR (keep process) +FR_OPEN equ 3D00h ;open file +FR_CLOSE equ 3E00h ;close file +FR_READ equ 3F00h ;read from file +FR_RELMEM equ 4900h ;release memory block +FR_EXEC equ 4B00h ;bid (exec) child process +FR_FIND1 equ 4E00h ;find match file + +; .EXE states +EXE_NONE equ 0 ;this spot is open (haven't EXEC'ed child) +EXE_TSR equ 1 ;have EXEC'ed child but not yet TSR'ed it +EXE_NORM equ 2 ;child loaded and waiting +EXE_TERM equ 3 ;child terminating + +; File block flags +FB_NEAR equ 01h ;1=copy to child's space (near data) + ;0=no copy (far data) +FB_INT equ 02h ;1=convert PCS integers to 16-bit int's + ;0=convert to 32-bit longint's +FB_KEEPENV equ 04h ;1=don't release child's env block + ;0=we do it for child automatically +FB_PAD equ 08h ;1=space each arg in dest 8 bytes apart + ;0=pack args contiguously +FB_SYSINT equ 10h ;1=system callable routine + ;0=normal xli routine + +; Special services +SS_SWAP equ 1 ;swap + +; PSP offsets +env_ptr equ 02Ch ;env block offset +fb_ptr equ 05Ch ;file block offset + + + \ No newline at end of file diff --git a/xli.mac b/xli.mac new file mode 100644 index 0000000..1f57ab3 --- /dev/null +++ b/xli.mac @@ -0,0 +1,181 @@ + subttl Macro definitions + +; In segment 'segzero' set $ to the next multiple of 'n'. +align macro n,segzero + org $ - (($-segzero) MOD n) + n + endm + +; Issue a DOS function request (int 21h) after +; setting up registers ax,bx,cx,dx,ds,es. +; Registers not specified are not affected by the macro, +; code to move a reg to itself is skipped, and +; moves between DS and ES are handled. +dos_fr macro rax,rbx,rcx,rdx,rds,res + ifnb ;;ax + ifidn , + else + mov ax,rax + endif + endif + ifnb ;;bx + ifidn , + else + mov bx,rbx + endif + endif + ifnb ;;cx + ifidn , + else + mov cx,rcx + endif + endif + ifnb ;;dx + ifidn , + else + mov dx,rdx + endif + endif + ifnb ;;es + ifidn , + push ds + pop es + else + ifidn , + else + mov es,res + endif + endif + endif + ifnb ;;ds + ifidn , + push es + pop ds + else + ifidn , + else + mov ds,rds + endif + endif + endif + int 21h + endm + +; Given the value of "active_exe", put into BX the corresponding byte offset +; into various tables. If table="itself", just load BX. +; +; Note: The calculated byte offset must fit into BL because we use BH for +; scratch. We don't affect any other register this way. If the +; number of entries allowed in the tables is enlarged so that we +; could overflow into BH, this macro will need changing. Changing +; a table's format will obviously affect this macro too. +load_index macro table + mov bx,active_exe + ifdif , + xor bh,bh + endif + ifidn ,
+ shl bx,1 ;; 2 bytes/entry + endif + ifidn ,
+ shl bx,1 ;; 4 + shl bx,1 + endif + ifidn ,
+ shl bx,1 ;; 4 + shl bx,1 + endif + ifidn ,
+ mov bh,bl + shl bx,1 ;;shift BH and BL simultaneously + shl bl,1 + shl bl,1 + add bl,bh ;; 10 + xor bh,bh + endif + ifidn ,
+ shl bx,1 ;; 2 + endif + endm + +; *** All registers on entry except CS,IP belong to the child. *** +; *** On exit, all registers except CS,IP,DS still belong to the child. *** +; This routine captures all the child's registers' values (except CS:IP, +; which is located on the stack at the saved SS:SP). +; DS is changed to PCS's data segment. +save_state macro + push ds ;pushes are in child's data segment + push ax + mov ax,data + mov ds,ax ;DS points to PCS's data segment + pop ax ;get back ax + mov save_ax,ax + mov save_bx,bx + mov save_cx,cx + mov save_dx,dx + mov save_si,si + mov save_di,di + pop ax ;get back ds (stack now same as on entry) + mov save_ds,ax + mov save_es,es + mov save_ss,ss + mov save_sp,sp + mov save_bp,bp + endm + +; Save the parent's (i.e. PCS's) segment and pointer registers. +save_parent macro + mov pcs_state.st_es,es ;save our state + mov pcs_state.st_ss,ss + mov pcs_state.st_sp,sp + mov pcs_state.st_bp,bp + mov pcs_state.st_ds,ds + endm + +; Restore the parent's segment and pointer registers. +restore_parent macro + mov bx,offset pcs_state ;restore parent's state + cli + mov es,[bx].st_es + mov ss,[bx].st_ss + mov sp,[bx].st_sp + mov bp,[bx].st_bp +;; mov ds,[bx].st_ds ;save_state made DS active already + sti + endm + +; Save off our registers and restore child's, then resume child. +call_child macro x + save_parent + load_index state_table + lea bx,state_table[bx] + cli ; restore child's state + mov es,[bx].st_es + mov ss,[bx].st_ss + mov sp,[bx].st_sp + mov bp,[bx].st_bp + mov ds,[bx].st_ds + sti +xlidbg&x label byte + nop ;;this gets replaced with INT 3 for debug + nop + db 0CBh ;resume child via far return + endm + +; Save off child's registers and restore ours, then continue. +resume_parent macro + save_state ;save child's registers in global area + restore_parent + load_index state_table + lea bx,state_table[bx] + mov ax,save_ds ;save child's regs in child-local area + mov [bx].st_ds,ax + mov ax,save_es + mov [bx].st_es,ax + mov ax,save_ss + mov [bx].st_ss,ax + mov ax,save_sp + mov [bx].st_sp,ax + mov ax,save_bp + mov [bx].st_bp,ax + endm + \ No newline at end of file diff --git a/xli_pro.mac b/xli_pro.mac new file mode 100644 index 0000000..720d451 --- /dev/null +++ b/xli_pro.mac @@ -0,0 +1,185 @@ +IFNDEF BLOCK_XFER +BLOCK_XFER equ 0EC00h ; Block Transfer +ENDIF + +IFNDEF DOS +DOS equ 021h ; Dos Function Request +ENDIF + +;MOVE_ARGS_TO_BUF +; Move the specified arguments to a buffer. If the buffer is not +; specified, then ES:DI is assumed to contain the address of the +; buffer. +; +; The specified args are pushed onto the local stack, and the +; address noted in DS:SI. The args are then moved to the +; specifed buffer. +move_args_to_buf macro args,realaddr,autobump,save +numbytes = 0 + irp x, + numbytes = numbytes + 2 + push x + endm +IFNB + les di,dword ptr ss:&realaddr +ENDIF + mov cx,numbytes + mov si,sp + move_to_real_buf autobump,save + add sp,numbytes +endm + +;MOVE_TO_REAL_BUF +; Move CX number of bytes from DS:SI to buffer specifed in ES:DI. +; Since the destination may be in real mode, use the AIA Dos +; extended function Block_Xfer. +move_to_real_buf macro autobump,save_offset + mov ax,BLOCK_XFER + int DOS +IFNB +IFE direction + add di,cx +ELSE + sub di,cx +ENDIF +ENDIF +IFNB + mov ss:&real_buf_offset,di +ENDIF +endm + +;MOVE_BYTE_TO_BUF +; Move one byte from the buffer specified in DS:SI to the +; destination address in ES:DI. +MOVE_BYTE_TO_BUF macro byt,realaddr,autobump +IFNB + les di,dword ptr ss:&realaddr +ENDIF + sub sp,2 + mov si,sp + mov byte ptr ss:[si],byt + mov cx,1 + mov ax,BLOCK_XFER + int DOS +IFNB +IFE direction + inc di +ELSE + dec di +ENDIF +ENDIF + add sp,2 +endm + +;MOVE_ARGS_FROM_BUF +; Get the specified arguments from a buffer. If the buffer is not +; specified, then ES:DI is assumed to contain the address of the +; buffer. +; +; The number of bytes specified by the args is allocated on +; the local stack, and the address noted in DS:SI. The args +; are then moved from the desired buffer onto the local stack, +; and popped into the desired args. +move_args_from_buf macro args,realaddr +numbytes = 0 + irp x, + numbytes = numbytes + 2 + endm +IFNB + les di,dword ptr ss:&realaddr +ENDIF + mov cx,numbytes + sub sp,cx + mov si,sp + move_from_real_buf + irp x, + pop x + endm +endm + +;MOVE_FROM_REAL_BUF +; Move CX number of bytes from the buffer specified in ES:DI to +; the destination address in DS:SI. Swap the source and +; destination registers and perform the AIA Dos extended function +; Block_Xfer (in case the source buffer is in real memory). +move_from_real_buf macro + mov bx,es + mov dx,ds + mov ds,bx + mov es,dx + xchg di,si + mov ax,BLOCK_XFER + int DOS + mov ds,dx + mov es,bx + xchg di,si +endm + +;REAL_BYTE_TO REG +; Move a byte from the buffer specified by DS:SI to a register. +; +; ES must equal SS +real_byte_to_reg macro reg,autobump + push cx + mov cx,1 + sub sp,2 + mov di,sp + mov ax,BLOCK_XFER + int DOS + mov al,byte ptr es:[di] +IFNB + inc si +ENDIF + add sp,2 + pop cx +endm + + +reset_real_buffer_offset macro + mov ss:real_buf_offset,0 +endm + + +save_real_buffer_offset macro arg +IFNB + mov ss:&real_buf_offset,arg +ELSE + mov ss:&real_buf_offset,di +ENDIF +endm + + +direction = 0 ; direction flag for autoincr/autdecr +real_buffer_stack = 0 ; treat buffer as stack + +buffer_is_stack macro + direction = 1 +endm + +get_real_buffer_stack macro + mov bx,ss:&real_buf_top + mov ss:&real_buf_offset,bx + direction = 1 +endm + +get_real_buffer macro + les di,dword ptr ss:&real_mode_buffer +endm + +buffer_is_buffer macro + direction = 0 +endm + +get_real_buffer_top macro reg + mov reg,ss:real_buf_top +endm + +get_buffer macro + buffer_is_buffer + reset_real_buffer_offset + get_real_buffer +endm + +rls_buffer macro + reset_real_buffer_offset +endm \ No newline at end of file diff --git a/zio.asm b/zio.asm new file mode 100644 index 0000000..024557e --- /dev/null +++ b/zio.asm @@ -0,0 +1,850 @@ +; =====> ZIO.ASM +;**************************************** +;* TIPC Scheme Runtime Support * +;* File IO - MS-DOS Version 2.1 * +;* * +;* (C) Copyright 1985 by Texas * +;* Instruments Incorporated. * +;* All rights reserved. * +;* * +;* Date Written: 21 January 1985 * +;* Last Modification: 26 September 1986 * +;**************************************** + page 60,132 + include scheme.equ + include pcmake.equ + +MSDOS equ 021h +TI_CRT equ 049h +IBM_CRT equ 010h +TI_KEYBD equ 04Ah +IBM_KEYB equ 016h + +MAX_COLS equ 80 +MAX_ROWS equ 25 + +CURSMASK equ 10011111b ; The zeros are the bits that disable cursor +NOCURSOR equ 00100000b ; byte mask to disable cursor + +DGROUP group data +data segment word public 'DATA' + assume DS:DGROUP + public zapcurs,curs_sav, ega_col, ega_row + +zapcurs dw 0 ; for disabling cursor altogether +curs_sav dw 400Ch ; For saving the cursor size when it's + ; disabled. Default value just in case... + +ega_col db ? +ega_row db ? +c_row dw ? +c_col dw ? +c_len dw ? + +banka dw 0a000h + +sav_di dw ? + + extrn vid_mode:word + extrn cur_off:byte + extrn char_hgt:word + +data ends + +XGROUP group progx +progx segment word public 'progx' + assume CS:XGROUP + extrn z%border:far ; border drawer + extrn crt_dsr:far ; use machine appropriate VIDEO interrupt + extrn save%scr:far ; save screen + extrn rest%scr:far ; restore screen + + extrn ega_curs:far ; display an ega cursor + extrn enable:far ; part of the ega cursor routine + +;************************************************************************ +;* Generate a Bell Character * +;* * +;* Purpose: To generate a "bell character" (i.e., make a noise) to * +;* simulate the effect of outputting a bell character * +;* (control-G) in the output stream. * +;* * +;* Calling Sequence: zbell(); * +;* * +;* Input Parameters: None. * +;* * +;* Output Parameters: None. * +;* * +;************************************************************************ + public zbell +zbell proc far + cmp DGROUP:PC_MAKE,TIPC + jne zbmbell +zbwait: mov AH,1 ; Get speaker status + int 48h + jnz zbwait ; wait for bell to turn off + mov AH,2 ; Set speaker frequency + mov CX,1563 ; Value for 1.25MHz/800Hz (system beep) + int 48h + mov AX,000Ah ; Turn speaker on for AL*25-ms. 0Ah = .25-sec + int 48h + ret ; return to caller +; +zbmbell: mov BX,080h ; ****Copied from IBM-PC/XT BIOS listing**** + in AL,61h + push AX ; Save +beep_cycle: and AL,0FCh ; Turn off timer gate and speaker data + out 61h,AL ; output to control + mov CX,48h ; Half cycle time for TONE +here: loop here ; speaker off + or AL,2 ; Turn speaker on + out 61h,AL + mov CX,48h +here2: loop here2 + dec BX ; Decrease cycle count + jnz beep_cycle + pop AX + out 61h,AL + ret +zbell endp + + public zch_rdy +zch_rdy proc far + +; IFDEF extmem ; Kludge to fix hanging keyboard +; mov AL,0AEh ; Ensure keyboard enabled +; out 64h,AL ; Output to 8042 controller +; ENDIF + + mov AH,01h ; load "check keyboard status" function code + cmp pc_make,TIPC ; TI or IBM flavored PC? + jne zch_IBM + int TI_KEYBD ; issue TI keyboard DSR service call + jz zch_no ; is character buffered? if not, jump +zch_yes: xor AH,AH ; clear high order byte of AX + cmp AL,0 ; test next character to be read + jne zch_ret ; binary zero? if not, jump + mov AX,256 ; if character is 0, make it non-zero +zch_ret: ret ; return (true) +zch_IBM: int IBM_KEYB ; issue IBM keyboard DSR service call + jnz zch_yes ; is character buffered? if so, jump +zch_no: xor AX,AX ; set result = false + ret ; return (false) +zch_rdy endp + +zop_args struc + dd ? ; far CS and IP + dw ? ; caller's BP + dw ? ; return address +zhandle dw ? ; address of handle +zpathnam dw ? ; address of string containing file pathname +zmode dw ? ; mode: 0=read, 1=write, 2=read/write +zhigh dw ? ; address of high word of file size +zlow dw ? ; address of low word of file size +zop_args ends + + public z%open +z%open proc far + push BP ; save caller's BP + mov BP,SP + mov AH,03Dh ; load function request id + mov AL,byte ptr [BP].zmode ; load access code (mode) + mov DX,[BP].zpathnam ; load pointer to pathname + int MSDOS ; issue open request + jc zop_ret ; if error, jump + mov BX,[BP].zhandle ; load address of handle + mov [BX],AX ; and store returned handle value +; + push AX ; save file handle + mov BX,AX ; set bx to file handle + xor CX,CX + xor DX,DX + mov AX,4202h ; poisition file pointer at eof + int MSDOS +; + mov BX,[BP].zhigh ; load address of hsize + mov [BX],DX ; and store returned hsize value + mov BX,[BP].zlow ; load address of lsize + mov [BX],AX ; and store returned lsize value +; + pop BX ; retrieve file handle + xor CX,CX + xor DX,DX + mov AX,4200h ; reset file pointer to begining of file + int MSDOS +; + xor AX,AX ; set return code for normal return +zop_ret: pop BP ; restore caller's BP + ret ; return +z%open endp + + public z%create +z%create proc far + push BP ; save caller's BP + mov BP,SP + mov AH,03Ch ; load function request id + mov DX,[BP].zpathnam ; load pointer to pathname + mov CX,020h ; create with "archive" attribute + int MSDOS ; issue create request + jc zcr_ret ; if error, jump + mov BX,[BP].zhandle ; load address of handle + mov [BX],AX ; and store returned handle value + xor AX,AX ; set return code for normal return +zcr_ret: pop BP ; restore caller's BP + ret ; return +z%create endp + + public z%close +z%close proc far + push BP ; save caller's BP + mov BP,SP + mov AH,03Eh ; load function request id + mov BX,[BP].zhandle ; load handle of file to close + int MSDOS ; issue close request + jc zcl_ret ; if error, jump + xor AX,AX ; set return code for normal return +zcl_ret: pop BP ; restore caller's BP + ret ; return +z%close endp + +zrw_args struc + dd ? ; far cs and ip + dw ? ; caller's BP + dw ? ; return address + dw ? ; zhandle (use previous equate) +zbuffer dw ? ; input/output buffer +zlength dw ? ; address of length value +zrw_args ends + + public z%read +z%read proc far + push BP ; save caller's BP + mov BP,SP + mov AH,03Fh ; load function request id + mov DX,[BP].zbuffer ; load address of input buffer + mov BX,[BP].zlength ; load address of length value + mov CX,[BX] ; then load length for read + mov BX,[BP].zhandle ; load file's handle + int MSDOS ; issue create request + jc zrd_ret ; if error, jump + mov BX,[BP].zlength ; load address of length parameter + mov [BX],AX ; and store number of characters read + xor AX,AX ; set return code for normal return +zrd_ret: pop BP ; restore caller's BP + ret ; return +z%read endp + + public z%write +z%write proc far + push BP ; save caller's BP + mov BP,SP + mov AH,040h ; load function request id + mov DX,[BP].zbuffer ; load address of input buffer + mov BX,[BP].zlength ; load address of length value + mov CX,[BX] ; then load length for write + mov BX,[BP].zhandle ; load file's handle + int MSDOS ; issue write request + jc zwr_ret ; if error, jump + mov BX,[BP].zlength ; load address of length parameter + mov [BX],AX ; and store number of characters written + xor AX,AX ; set return code for normal return +zwr_ret: pop BP ; restore caller's BP + ret ; return +z%write endp + +strd struc + dd ? ; far cs and ip + dw ?,? ;Caller's BP, Return address +strdpg dw ? ;Page, displacement of port +strdds dw ? +strdbuf dw ? ;Buffer address +strdlen dw ? ;Length address +strd ends + public string%rd +string%rd proc far + push BP + mov BP,SP + push DS ;Save caller's DS, ES + mov AX,ES ; (and make AX nonzero as well) + mov BX,[BP].strdlen ;Load CX with number of chars to transfer + mov CX,[BX] + mov DI,[BP].strdpg ;Get port page + mov DX,DI ; and save for later + %LoadPage DS,DI ;Get para address + mov DI,[BP].strdds ;DS:DI point to port + mov SI,word ptr[DI+car].pt_ptr ;Point DS:SI to string + mov BL,[DI+car_page].pt_ptr + xor BH,BH + %LoadPage DS,BX +;;; mov DS,ES:pagetabl+[BX] + cmp byte ptr[SI],STRTYPE ;Is this a string? + jne nostr ;Jump if not (error) + mov BX,[SI].str_len ;Else fetch string length + cmp BX,0 ;;; check for small string + jge strn_01 + add BX,BLK_OVHD+PTRSIZE +strn_01: %LoadPage ES,DX ;Restore ptr to port + mov DX,ES:[DI].pt_ullin ;Fetch position within string + sub BX,DX ;Set BX to # of chars left + jns notpast ;If not negative, skip + xor BX,BX ;Set # of chars left to 0 +notpast: cmp BX,CX ;Set CX to # of chars left or maximum + jae max ; called for, whichever is smaller + mov CX,BX +max: add SI,DX ;Adjust SI into string + add DX,CX ;Reset pointer into string + mov ES:[DI].pt_ullin,DX + mov ES,AX ;Restore C's ES + mov DI,[BP].strdbuf ;Point DI to buffer + xor AX,AX ;Prepare to return 0 (all's well) + jmp short storlen ;Store # of chars +nostr: xor CX,CX ;When not a string, move no chars +storlen: mov BX,[BP].strdlen ;Set LENGTH to # of chars read + mov ES:[BX],CX + rep movsb ;Transfer bytes + pop DS ;Restore caller's DS + pop BP + ret +string%rd endp + +;************************************************************************ +;* Buffered Keyboard Input * +;* * +;* Calling Sequence: ch = getch(); * +;* where ch - the character read from the keyboard * +;************************************************************************ + public get%ch +get%ch proc far + +; IFDEF extmem ; Kludge to fix hanging keyboard +; mov AL,0AEh ; Ensure keyboard enabled +; out 64h,AL ; Output to 8042 controller +; ENDIF + + mov AH,07h ; function code = Direct Console Input + int MSDOS ; do it + xor AH,AH ; clear the high order byte + ret ; return to caller +get%ch endp + +z%ega proc far + + mov AX,banka + mov ES,AX ; set ES to the video plane + + mov AX,c_row ; set AX to the row + mul char_hgt ; multiply by the character height + mov BX,80 ; multiply by 80 bytes per line + mul BX + add AX,c_col ; add in the starting column + mov sav_di,AX ; save the starting value + xor BX,BX ; use BX as a counter + mov DX,c_len ; number of columns to blank + +zc_03: mov CX,DX ; restore counter + mov DI,sav_di ; restore index + mov AH,0fh + call enable ; enable all banks + xor AX,AX ; clear AX + cld +rep stosb + + add sav_di,80 ; next line + inc BX ; increment counter + cmp BX,char_hgt ; done with this row? + jne zc_03 + + xor BX,BX ; clear counter + dec [BP].zc_nrows ; decrement row count + jg zc_03 ; if more rows, loop (jump) + ret +z%ega endp + +progx ends + + +PGROUP group prog +prog segment byte public 'PROG' + assume CS:PGROUP + +;************************************************************************ +;* Create a File * +;* * +;* Calling sequence: stat = zcreate(handle, pathname) * +;* where: int *handle - location to store handle * +;* returned by open request* +;* char *pathname - zero terminated string * +;* containing the file's * +;* pathname * +;* int stat - the completion code * +;* 0=no errors * +;* 3=path not found * +;* 4=too many open files * +;* 5=access denied * +;************************************************************************ + public zcreate +zcreate proc near + call z%create + ret ; return +zcreate endp + +;************************************************************************ +;* Open a File * +;* * +;* Calling sequence: stat = zopen(handle, pathname, access_code) * +;* where: int *handle - location to store handle * +;* returned by open request* +;* char *pathname - zero terminated string * +;* containing the file's * +;* pathname * +;* int access_code - 0=read, 1=write, * +;* 2=read and write * +;* int stat - the completion code * +;* 0=no errors * +;* 2=file not found * +;* 4=too many open files * +;* 5=access denied * +;* 12=invalid access * +;************************************************************************ + public zopen +zopen proc near + call z%open + ret ; return +zopen endp + +;************************************************************************ +;* Close a File * +;* * +;* Calling sequence: stat = zclose(handle) * +;* where: int handle - handle returned by open * +;* request * +;* int stat - the completion code * +;* 0=no errors * +;* 6=invalid handle * +;************************************************************************ + public zclose +zclose proc near + call z%close + ret ; return +zclose endp + +;************************************************************************ +;* Read From a File * +;* * +;* Calling sequence: stat = zread(handle, buffer, length) * +;* where: int handle - handle returned by open * +;* request * +;* char *buffer - address of character * +;* buffer into which data * +;* is to be read * +;* int *length - on input, the maximum * +;* number of characters * +;* which the buffer will * +;* hold. On output, the * +;* number of characters * +;* actually read. Note: * +;* a return value of zero * +;* characters read * +;* indicates end of file. * +;* int stat - the completion code * +;* 0=no errors * +;* 5=access denied * +;* 6=invalid handle * +;************************************************************************ + + public zread +zread proc near + call z%read + ret ; return +zread endp + +;************************************************************************ +;* Write to a File * +;* * +;* Calling sequence: stat = zwrite(handle, buffer, length) * +;* where: int handle - handle returned by open * +;* char *buffer - address of character * +;* buffer from which data * +;* is to be written * +;* int *length - on input, the number of * +;* characters to write. * +;* The actual number of * +;* characters which were * +;* written is returned in * +;* "length" * +;* int stat - the completion code * +;* 0=no errors * +;* 5=access denied * +;* 6=invalid handle * +;************************************************************************ + public zwrite +zwrite proc near + call z%write + ret ; return +zwrite endp + +;************************************************************************ +;* Clear a Window * +;************************************************************************ +zc_args struc + dw ? ; caller's BP + dw ? ; return address +zc_row dw ? ; upper left hand corner row number +zc_col dw ? ; upper left hand corner column number +zc_nrows dw ? ; number of rows +zc_len dw ? ; line length (number of characters) +zc_attrib dw ? ; character attributes +zc_args ends + + public zclear +zclear proc near + push BP ; save caller's BP + mov BP,SP + push ES + push DI + push AX + push BX + push CX + push DX +; Put cursor at beginning of next row +zc_loop: mov DL,byte ptr [BP].zc_row ; load current row number + mov DH,byte ptr [BP].zc_col ; load starting column number + xor BH,BH ; page number (0 if in graphics mode) + mov AH,02H ; load "put cursor" code + call crt_dsr ; position the cursor +; Write line of blanks at current cursor position + mov AX,0920h ; load write char/attr code + blank (= 20h) + xor BH,BH ; (for IBM-PC BH=display page #) + mov BL,byte ptr [BP].zc_attrib ; load attribute flag + cmp vid_mode,14 ; IBM EGA modes? + jl zc_01 + cmp BL,87h ; attribute is rv white? + jne zc_22 + mov AX,09dbh ; use the block character not the blank + and BL,7fh ; strip off the xor bit +zc_01: mov CX,[BP].zc_len ; load number of times to write the blank + call crt_dsr ; perform the write +; Increment row number, decrement row count, test, loop + inc [BP].zc_row ; increment row number + dec [BP].zc_nrows ; decrement row count + jg zc_loop ; if more rows, loop (jump) +; Return to caller +zc_end: pop DX + pop CX + pop BX + pop AX + pop DI + pop ES + pop BP ; restore caller's BP + ret ; return + +; clear out the line by writing directly to the graphics planes +zc_22: mov AX,[BP].zc_row ; set AX to the row + mov c_row,AX + mov AX,[BP].zc_col ; add in the starting column + mov c_col,AX + mov AX,[BP].zc_len ; number of columns to blank + mov c_len,AX + call z%ega ; restore counter + + jmp zc_end ; return + +zclear endp + +;************************************************************************ +;* Draw Border * +;************************************************************************ +zb_args struc + dw ? ; caller's BP + dw ? ; return address +zb_line dw ? ; upper left corner line number +zb_col dw ? ; upper left corner column number +zb_nlines dw ? ; number of lines +zb_ncols dw ? ; number of columns +zb_battr dw ? ; border attributes +zb_label dw ? ; pointer to label text +zb_args ends + + public zborder +zborder proc near + call z%border + ret +zborder endp + +;************************************************************************ +;* Link to Save Screen Support * +;************************************************************************ + public save_scr +save_scr proc near + call save%scr + ret +save_scr endp + +;************************************************************************ +;* Link to Restore Screen Support * +;************************************************************************ + public rest_scr +rest_scr proc near + call rest%scr + ret +rest_scr endp + +;************************************************************************ +;* Cursor Off * +;************************************************************************ + public zcuroff +zcuroff proc near + + call ega_curs + + mov AH,03 + xor BH,BH ; IBM page number/must be 0 for graphics mode + call crt_dsr ; get the cursor position/mode + + cmp zapcurs,0 + jne zcoff_01 + mov curs_sav,CX ; save it for restoration +zcoff_01: + and CH,CURSMASK ; mask off bits to select cursor type + or CH,NOCURSOR ; disables cursor (turns it off) + mov AH,01h ; load "set cursor type" code + call crt_dsr ; turn the cursor off + ret ; return to caller +zcuroff endp + + +;************************************************************************ +;* Cursor On * +;************************************************************************ + public zcuron +zcuron proc near + + cmp zapcurs,0 ; if cursor disabled + jne zcon_ret ; then return + + mov CX,curs_sav ; attributes for cursor on + mov AH,01h ; load "set cursor type" code + call crt_dsr ; turn the cursor on +zcon_ret: + ret ; return to caller +zcuron endp + +;************************************************************************ +;* Put Cursor * +;************************************************************************ + public zputcur +zputcur proc near + + push BP ; save caller's BP + mov BP,SP +; put cursor in desired location + mov DH,byte ptr [BP].zc_col ; load column number + mov ega_col,DH + mov DL,byte ptr [BP].zc_row ; load row number + mov ega_row,DL + xor BH,BH ; IBMism: page number (0 if in graphics mode) + mov AH,02H ; load "put cursor" code + call crt_dsr ; position the cursor (DSR swaps DH/DL) + + call ega_curs ; display cursor for ega mode + +; Return to caller + pop BP ; restore caller's BP + ret ; return +zputcur endp + +;************************************************************************ +;* Scroll a Window * +;************************************************************************ +zs_args struc + dw ? ; caller's BP + dw ? ; return address +zs_line dw ? ; upper left hand corner line number +zs_col dw ? ; upper left hand corner column number +zs_nline dw ? ; number of lines +zs_ncols dw ? ; number of columns +zs_attr dw ? ; text attributes (used for blanking) +zs_args ends + + public zscroll +zscroll proc near + push BP ; save caller's BP + mov BP,SP + push AX + push BX + push CX + push DX +; scroll window's text up one line + mov CL,byte ptr [BP].zs_nline ; load number of lines + dec CL ; decrease number of lines by one + jz blank1 ; Jump if scrolling 1-line and just blank it + mov CH,byte ptr [BP].zs_ncols ; load number of columns + mov DL,byte ptr [BP].zs_line ; load upper left line number + mov DH,byte ptr [BP].zs_col ; load upper left column number + mov AX,0601h ; load "scroll text" code with no blanking + cmp DGROUP:PC_MAKE,TIPC + je ti_scrl +;;;;;;;;; cmp vid_mode,14 +;;;;;;;;; jge txt_mod ; treat ega modes as text + cmp vid_mode,4 ; Are we in graphics mode? + jl txt_mod ; If we are then fix blank fill attributes + cmp vid_mode,7 ; so that the bar characters don't show up + je txt_mod + xor BH,BH ; zero attribute for fill blanks + jmp short rite_atr +txt_mod: mov BH,byte ptr [BP].zs_attr ; Blanked lines' attribute txt mode +rite_atr: 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 z_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_scrl: mov BX,DX ; copy destination coordinates + inc DL ; compute source by incrementing line number + int TI_CRT ; perform block move +; paint the last line of the window with blank of proper attributes +blank1: mov DH,byte ptr [BP].zs_col ; load starting column number + mov DL,byte ptr [BP].zs_line ; load upper line number + add DL,byte ptr [BP].zs_nline ; add the number of lines and + dec DL ; subtract offf one + mov AH,02h ; load "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].zs_attr ; load attribute bit setting + + cmp vid_mode,14 ; ega mode? + jl z_scr01 + mov BH,BL + and BH,80h + cmp BH,80h ; reverse video? + jne z_scr01 + mov AX,09dbh ; change for block character + and BL,7fh ; strip off xor bit +z_scr01: xor BH,BH ; IBMism + mov CX,[BP].zs_ncols ; load line length + call crt_dsr ; write a line of blanks +; return to caller +z_quit: pop DX ; restore caller's BP + pop CX + pop BX + pop AX + pop BP + ret +zscroll endp + +;************************************************************************ +;* Output Character To Window * +;************************************************************************ +zp_args struc + dw ? ; caller's BP + dw ? ; return address +zp_line dw ? ; cursor position - line number +zp_col dw ? ; cursor position - column number +zp_char dw ? ; character to write +zp_attr dw ? ; character's attributes +zp_args ends + + public zputc +zputc proc near + push BP ; save caller's BP + mov BP,SP + push DX + push CX + push BX + push AX +; position cursor for write + mov DL,byte ptr [BP].zp_line ; load line number + mov DH,byte ptr [BP].zp_col ; load column number + xor BH,BH ; IBMism + mov AH,02h ; load "put cursor" code + call crt_dsr ; positio the cursor + + mov BL,byte ptr [BP].zp_attr ; load its attributes + cmp vid_mode,14 ; only attribute for EGA modes is a + jl zchar_1 ; simulated reverse video + + mov BH,BL ; save the attribute + and BH,80h ; reverse video? + jz zchar_1 ; zero indicates bit 8 not set + +zchar_2: and BL,7fh ; strip off high bit + mov CX,1 ; character count + xor BH,BH ; video page number + mov AL,0dbh ; block character + mov AH,09h + call crt_dsr + or BL,80h ; set xor bit +; write the characters with attributes +zchar_1: mov AL,byte ptr [BP].zp_char ; load the character + xor BH,BH ; IBMism + mov CX,1 ; repeat count = 1 + mov AH,09h ; load write char/attribute code + call crt_dsr +; return to caller + pop AX + pop BX + pop CX + pop DX + pop BP + ret +zputc endp + +;************************************************************************ +;* Buffered Keyboard Input * +;* * +;* Calling Sequence: ch = getch(); * +;* where ch - the character read from the keyboard * +;************************************************************************ + public getch +getch proc near + call get%ch + ret ; return to caller +getch endp + +;************************************************************************ +;* Read characters from a string * +;* * +;* Calling Sequence: stringrd(page, disp, buffer, &length) * +;* where page,disp: location of string-fed port * +;* buffer and length are as in ZREAD (see above) * +;* * +;* Note: The passing parameter `page' is page # * +;************************************************************************ + + public stringrd +stringrd proc near + call string%rd + ret +stringrd endp +;*************************************************************************** +;* Link for routines in PROGX * +;*************************************************************************** + extrn shft_brk:near + extrn dos_err:near + public shft%brk + public dos%err +shft%brk proc far + call shft_brk ;link to SHF BREAK process + ret +shft%brk endp + +dos%err proc far + call dos_err ;link to DOS fatal error process + ret +dos%err endp +; + public char_rdy +char_rdy proc near ;our equivalent of Lattice C's kbhit fn + call zch_rdy + ret +char_rdy endp + +prog ends + + end + \ No newline at end of file