What is it? =========== This file is an integrated set of patches for the 28sep90 version of the Scheme->C system. These patches add support for the Sun4/Sparcstation (SPARC), the Sun3 (SUN3), the Apollo DNx500 (APOLLO) and DN1000 (PRISM) series, and the the 386 (running ISC Unix ?). Most of this is not new work, I simply integrated all the patches that were posted for the 23feb90 version. I have verified this patch on the following machine/OS combinations: Sun4 - SunOS 4.0.3 Sun4 - SunOS 4.1 Sun3 - SunOS 4.0.3 Apollo DN3500 - Domain/OS SR10.2 DECSTATION 5100 - Ultrix T3.1D-0 (Rev. 45) Worksystem X2.2 System #3 How to use it. ============== This patch was generated against a fresh, unmodified version of the 28sep90 release of Scheme->C. I suggest you start with the original tar file and untar it. 1. cd into the top directory of the distribution. You should see something like this from ls -F: CHANGES README doc/ scrt/ xlib/ MIPS VAX gnuemacs/ scsc/ RCS/ cdecl/ makefile test/ 2. Run the patch file through the patch program, like this ("this" assumes the patch file lives in the directory that is the top of the distribution): patch -p -b ".MCC" " command, where ARCH is one of APOLLO, I386, MIPS, PRISM, SPARC, SUN3, TITAN, or VAX. This will create the $(CPUDIR) directory, if it does not exist. It will then create a tree of symbolic links to all the directories and necessary files in the distribution. [ If you can accept the values for CPUDIR that already exist in the makefile, you can just say "make for SRCDIR=$PWD" where $PWD has a valid pathname to the currect directory] 5. cd into $(SRCDIR) which you set in #3 above. 6. Do a "make port" 7. Verify the build as in step #4 in the README file. More comments ============= Like I said, very little of this work is original. I simply took all the patches produced for the 23sep90 version and made them work. This involved fixing rejections, adding some new parts to the changes and removing some changes because the bug/problem they addressed was already fixed in the 28sep90 version. Here is a list of the authors of the original patches: SPARC - rec@arris.com (Roger Critchlow) I386 - rec@arris.com (Roger Critchlow) SUN3 - Mikael Pettersson APOLLO - Ray Lischner {uunet,decwrl}!mntgfx!lisch or lisch@mentor.com PRISM - Ray Lischner {uunet,decwrl}!mntgfx!lisch or lisch@mentor.com I am not able to verify the I386 nor the PRISM version of the system. I don't have access to those kinds of machines. The I386 patches seemed to mix conditionals between the 386 and SysV. It would be nice if someone with a 386 and SysV could figure out what things are SysV requirements. There are more SysV problems, though. You should look at the README that originally came with Critchlow's SPARC-I386 patches. The APOLLO and PRSIM machines don't usually have an assembler. Ray Lischner provided the assembler source and an assembled .o file. I have provided the uuencoded .o file. You could put the following section into the APOLLO makefile header to convert the uuencoded file into the .o file: apollo.o: apollo.o.uu uudecode apollo.o.uu There may be problems with the assembler, even if you have it. The assembler we have here at MCC will not take the muls.l or the mulu.l instructions. Conclusion ========== I hope you find these changes useful. If you have any problems please let me know. I appreciate any comments that you might have, good or bad. You can reach me via eckelkamp@mcc.com or uunet!cs.utexas.edu!milano!cadillac!davide. ____________________________________________________________________________ David Eckelkamp Microelectronics and Computer Technology Corp. (MCC) eckelkamp@mcc.com 3500 W. Balcones Center Dr. (512) 343-0978 Austin,TX 78759 *** /tmp/,RCSt1a07923 Mon Nov 12 11:05:59 1990 --- makefile Mon Nov 12 11:03:15 1990 *************** *** 16,25 **** --- 16,52 ---- VAXBIN = /wrl/vax/bin VAXLIB = /wrl/vax/lib + APOLLODIR = $(SRCDIR)/apollo + APOLLOBIN = $(SRCDIR)/bin.apollo + APOLLOLIB = $(SRCDIR)/lib.apollo + PRISMDIR = $(SRCDIR)/prism + PRISMBIN = $(SRCDIR)/bin.prism + PRISMLIB = $(SRCDIR)/lib.prism + + SPARCDIR = ${SRCDIR}/sparc + SPARCBIN = ${SRCDIR}/bin.sparc + SPARCLIB = ${SRCDIR}/lib.sparc + + SUN3DIR = ${SRCDIR}/sun3 + SUN3BIN = ${SRCDIR}/bin.sun3 + SUN3LIB = ${SRCDIR}/lib.sun3 + + I386DIR = ${SRCDIR}/i386 + I386BIN = ${SRCDIR}/bin.i386 + I386LIB = ${SRCDIR}/lib.i386 + + # This is a list of the machines/architectures that are currently supported. + # These are also the names of the necessary makefile fragements. + MACHINES = APOLLO I386 MIPS PRISM SPARC SUN3 TITAN VAX + # Architecture specific directories and links to the source files are # constructed by the following commands which follow: + no-target: + @echo 'Use "make for", where is one of:' + @echo ' $(MACHINES)' + forCPU: -mkdir ${CPUDIR} cp ${CPU} ${CPUDIR} *************** *** 64,157 **** -cd ${CPUDIR}/test; make srclinks forMIPS: ! make "CPU = MIPS" "CPUDIR = ${MIPSDIR}" \ "BINDIR = ${MIPSBIN}" "LIBDIR = ${MIPSLIB}" forCPU forTITAN: ! make "CPU = TITAN" "CPUDIR = ${TITANDIR}" \ "BINDIR = ${TITANBIN}" "LIBDIR = ${TITANLIB}" forCPU forVAX: ! make "CPU = VAX" "CPUDIR = ${VAXDIR}" \ "BINDIR = ${VAXBIN}" "LIBDIR = ${VAXLIB}" forCPU # The Scheme->C system is initially compiled from the C sources by the # following: port: ! cd scrt; make port ! cd scsc; make port # A "private" working copy of the current compiler, libary, and interpreter # is installed in a directory by the following command: install-private: ! cd scrt; make "destdir = ${destdir}" install-private ! cd scsc; make "destdir = ${destdir}" install-private # Clean out working files. clean: rm -f *.BAK *.CKP SC-TO-C* ! cd doc; make clean ! cd scrt; make clean ! cd scsc; make clean ! cd test; make clean # Clean up C source files generated from Scheme source. clean-sc-to-c: ! cd scrt; make clean-sc-to-c ! cd scsc; make clean-sc-to-c ! cd test; make clean-sc-to-c # Delete programs and libraries. noprogs: ! cd scrt; make noprogs ! cd scsc; make noprogs ! cd test; make noprogs # All binaries and documentation files are installed by the following command # for access by all users. install: ! cd doc; make "BINDIR = ${BINDIR}" "LIBDIR = ${LIBDIR}" install ! cd scrt; make "BINDIR = ${BINDIR}" "LIBDIR = ${LIBDIR}" install ! cd scsc; make "BINDIR = ${BINDIR}" "LIBDIR = ${LIBDIR}" install # All files which must be constructed are made by the following command: all: ! cd scrt; make all ! cd scsc; make all # Distribute "source" files required to make the Scheme->C system. srcdist: ! rdist -c MIPS README TITAN VAX makefile ${destdir} ! cd doc; make "destdir = ${destdir}/doc" srcdist ! -cd scbenchmark; make "destdir = ${destdir}/scbenchmark" srcdist ! cd scrt; make "destdir = ${destdir}/scrt" srcdist ! cd scsc; make "destdir = ${destdir}/scsc" srcdist ! -cd test; make "destdir = ${destdir}/test" srcdist ! -cd tools; make "destdir = ${destdir}/tools" srcdist # Distribute "binary" files so that they may be installed on some other # system. bindist: ! rdist -c MIPS README TITAN VAX makefile ${destdir} ! cd doc; make "destdir = ${destdir}/doc" bindist ! cd scrt; make "destdir = ${destdir}/scrt" bindist ! cd scsc; make "destdir = ${destdir}/scsc" bindist # Write the tar tape for distribution. ! TARFILES = CHANGES MIPS README VAX makefile \ doc/[a-z]*.mss doc/[a-z]*.psf doc/[a-z]*.l doc/makefile \ gnuemacs/README gnuemacs/[a-z]* \ scrt/[a-z]*.sc scrt/[a-z]*.[chs] scrt/makefile-tail \ scsc/[a-z]*.sc scsc/[a-z]*.c scsc/[a-z]*.sch scsc/makefile-tail \ test/[a-z]*.sc test/test54c.c test/makefile-tail \ cdecl/README cdecl/[a-z]* \ --- 91,207 ---- -cd ${CPUDIR}/test; make srclinks forMIPS: ! $(MAKE) "CPU = MIPS" "CPUDIR = ${MIPSDIR}" "SRCDIR = ${SRCDIR}" \ "BINDIR = ${MIPSBIN}" "LIBDIR = ${MIPSLIB}" forCPU forTITAN: ! $(MAKE) "CPU = TITAN" "CPUDIR = ${TITANDIR}" "SRCDIR = ${SRCDIR}" \ "BINDIR = ${TITANBIN}" "LIBDIR = ${TITANLIB}" forCPU forVAX: ! $(MAKE) "CPU = VAX" "CPUDIR = ${VAXDIR}" "SRCDIR = ${SRCDIR}" \ "BINDIR = ${VAXBIN}" "LIBDIR = ${VAXLIB}" forCPU + forAPOLLO: + $(MAKE) "CPU = APOLLO" "CPUDIR = ${APOLLODIR}" "SRCDIR = ${SRCDIR}" \ + "BINDIR = ${APOLLOBIN}" "LIBDIR = ${APOLLOLIB}" forCPU + cd $(APOLLODIR)/scrt; ln -s $(SRCDIR)/mul-fix.perl mul-fix.perl + + forPRISM: + $(MAKE) "CPU = PRISM" "CPUDIR = ${PRISMDIR}" "SRCDIR = ${SRCDIR}" \ + "BINDIR = ${PRISMBIN}" "LIBDIR = ${PRISMLIB}" forCPU + + forSPARC: + $(MAKE) "CPU = SPARC" "CPUDIR = ${SPARCDIR}" "SRCDIR = ${SRCDIR}" \ + "BINDIR = ${SPARCBIN}" "LIBDIR = ${SPARCLIB}" forCPU + + + forSUN3: + $(MAKE) "CPU = SUN3" "CPUDIR = ${SUN3DIR}" "SRCDIR = ${SRCDIR}" \ + "BINDIR=${SUN3BIN}" "LIBDIR=${SUN3LIB}" forCPU + + forI386: + $(MAKE) "CPU = I386" "CPUDIR = ${I386DIR}" "SRCDIR = ${SRCDIR}" \ + "BINDIR = ${I386BIN}" "LIBDIR = ${I386LIB}" forCPU + # The Scheme->C system is initially compiled from the C sources by the # following: port: ! cd scrt; $(MAKE) port ! cd scsc; $(MAKE) port # A "private" working copy of the current compiler, libary, and interpreter # is installed in a directory by the following command: install-private: ! cd scrt; $(MAKE) "destdir = ${destdir}" install-private ! cd scsc; $(MAKE) "destdir = ${destdir}" install-private # Clean out working files. clean: rm -f *.BAK *.CKP SC-TO-C* ! cd doc; $(MAKE) clean ! cd scrt; $(MAKE) clean ! cd scsc; $(MAKE) clean ! cd test; $(MAKE) clean # Clean up C source files generated from Scheme source. clean-sc-to-c: ! cd scrt; $(MAKE) clean-sc-to-c ! cd scsc; $(MAKE) clean-sc-to-c ! cd test; $(MAKE) clean-sc-to-c # Delete programs and libraries. noprogs: ! cd scrt; $(MAKE) noprogs ! cd scsc; $(MAKE) noprogs ! cd test; $(MAKE) noprogs # All binaries and documentation files are installed by the following command # for access by all users. install: ! cd doc; $(MAKE) "BINDIR = ${BINDIR}" "LIBDIR = ${LIBDIR}" install ! cd scrt; $(MAKE) "BINDIR = ${BINDIR}" "LIBDIR = ${LIBDIR}" install ! cd scsc; $(MAKE) "BINDIR = ${BINDIR}" "LIBDIR = ${LIBDIR}" install # All files which must be constructed are made by the following command: all: ! cd scrt; $(MAKE) all ! cd scsc; $(MAKE) all # Distribute "source" files required to make the Scheme->C system. srcdist: ! rdist -c $(MACHINES) README makefile ${destdir} ! cd doc; $(MAKE) "destdir = ${destdir}/doc" srcdist ! -cd scbenchmark; $(MAKE) "destdir = ${destdir}/scbenchmark" srcdist ! cd scrt; $(MAKE) "destdir = ${destdir}/scrt" srcdist ! cd scsc; $(MAKE) "destdir = ${destdir}/scsc" srcdist ! -cd test; $(MAKE) "destdir = ${destdir}/test" srcdist ! -cd tools; $(MAKE) "destdir = ${destdir}/tools" srcdist # Distribute "binary" files so that they may be installed on some other # system. bindist: ! rdist -c $(MACHINES) README makefile ${destdir} ! cd doc; $(MAKE) "destdir = ${destdir}/doc" bindist ! cd scrt; $(MAKE) "destdir = ${destdir}/scrt" bindist ! cd scsc; $(MAKE) "destdir = ${destdir}/scsc" bindist # Write the tar tape for distribution. ! TARFILES = CHANGES README $(MACHINES) makefile \ doc/[a-z]*.mss doc/[a-z]*.psf doc/[a-z]*.l doc/makefile \ gnuemacs/README gnuemacs/[a-z]* \ scrt/[a-z]*.sc scrt/[a-z]*.[chs] scrt/makefile-tail \ + scrt/[a-z]*.asm \ scsc/[a-z]*.sc scsc/[a-z]*.c scsc/[a-z]*.sch scsc/makefile-tail \ test/[a-z]*.sc test/test54c.c test/makefile-tail \ cdecl/README cdecl/[a-z]* \ *** /tmp/,RCSt1a27358 Fri Nov 9 17:25:53 1990 --- scrt/apply.h Fri Nov 9 14:05:39 1990 *************** *** 44,57 **** by the compiler to call unknown functions. */ - #ifdef MIPS - #define MAXARGS 25 /* Maximum number of required arguments permitted. - Note that this does not preclude an optional - argument list as an additional argument. This - number is typically determined by the ability - of one's C compiler. */ - #endif - #ifdef TITAN #define MAXARGS 16 /* Maximum number of required arguments permitted. Note that this does not preclude an optional --- 44,49 ---- *************** *** 58,66 **** argument list as an additional argument. This number is typically determined by the ability of one's C compiler. */ ! #endif ! ! #ifdef VAX #define MAXARGS 25 /* Maximum number of required arguments permitted. Note that this does not preclude an optional argument list as an additional argument. This --- 50,56 ---- argument list as an additional argument. This number is typically determined by the ability of one's C compiler. */ ! #else #define MAXARGS 25 /* Maximum number of required arguments permitted. Note that this does not preclude an optional argument list as an additional argument. This *** /tmp/,RCSt1a27363 Fri Nov 9 17:25:55 1990 --- scrt/callcc.c Fri Nov 9 14:05:43 1990 *************** *** 57,62 **** --- 57,74 ---- #include "callcc.h" #include "apply.h" #include "signal.h" + + #ifdef SPARC + extern sc_setjmp(); + /* This is really tacky, but it appears to be necessary because of the */ + /* compiler on the DECStation 5100. That beast does not seem to be able to */ + /* grok the #pragma directive. The one I tried appeared to be */ + /* Ultrix T3.1D-0 (Rev. 45) Worksystem X2.2. */ + #include "sparc-pragma.h" + #define setjmp( x ) sc_setjmp( x ) + #define longjmp( x, y ) sc_longjmp( x, y ) + #endif + #ifdef MIPS extern sc_setsp(); #endif *************** *** 66,71 **** --- 78,92 ---- #define setjmp( x ) sc_setjmp( x ) #endif + #ifdef APOLLO + extern sc_setregs(int a6, int a7); + #endif + + #ifdef PRISM + #define longjmp(x, y) sc_longjmp(x, y) + #define setjmp(x) sc_setjmp(x) + #endif + TSCP sc_clink; /* Pointer to inner most continuation on stack. */ /* Static declarations for data structures internal to the module. These *************** *** 97,102 **** --- 118,127 ---- it will restore the stack. */ #ifdef MIPS sc_setsp( (T_U(callcccp))->continuation.address ); + #endif + #ifdef APOLLO + sc_setregs( (T_U(callcccp))->continuation.savedstate[3], + (T_U(callcccp))->continuation.savedstate[2]); #endif longjmp( (T_U(callcccp))->continuation.savedstate, 1 ); } *** /tmp/,RCSt1a27372 Fri Nov 9 17:25:59 1990 --- scrt/cio.c Fri Nov 9 14:05:49 1990 *************** *** 46,51 **** --- 46,64 ---- #include #include "objects.h" + /* This really does not need to be dependant on ISC386IX, just the lack of */ + /* a rename function. This is just a dirty hack. */ + #ifdef ISC386IX + #include + #include + int rename(old, new) char *old, *new; + { + if (link(old, new) == 0 && unlink(old) == 0) + return 0; + return -1; + } + #endif + int sc_libc_eof = EOF; /* feof(stream) */ *************** *** 84,100 **** --- 97,124 ---- input characters ready, and 0 when none are available. */ + /* The changes here are probably generic Sys5 changes, but what the heck */ int sc_inputchars( stream ) FILE *stream; { int readfds, nfound; + #ifndef ISC386IX struct timeval timeout; + #else + struct pollfd pollfd; + #endif if (((stream)->_cnt) <= 0) { + #ifndef ISC386IX readfds = 1<<(fileno( stream )); timeout.tv_sec = 0; timeout.tv_usec = 0; nfound = select( fileno( stream )+1, &readfds, 0, 0, &timeout ); + #else + pollfd.fd = fileno( stream ); + pollfd.events = POLLIN; + nfound = poll(&pollfd, 1, 0); + #endif if (nfound == 0) return( 0 ); } return( 1 ); *** /tmp/,RCSt1a27381 Fri Nov 9 17:26:04 1990 --- scrt/heap.c Fri Nov 9 14:05:58 1990 *************** *** 59,64 **** --- 59,70 ---- #ifdef VAX extern sc_r2tor11(); #endif + #ifdef APOLLO + extern sc_regs(); + #endif + #ifdef SUN3 + extern sc_a2to5d2to7(); + #endif /* Forward declarations */ *************** *** 100,108 **** --- 106,116 ---- int sc_gcinfo; /* controls logging */ + #ifndef SYSV static struct rusage gcru, /* resource consumption during collection */ startru, stopru; + #endif int *sc_stackbase; /* pointer to base of the stack */ *************** *** 111,116 **** --- 119,125 ---- TSCP sc_after_2dcollect_v; /* Collection status callback */ + #ifndef SYSV /* The following function converts a rusage structure into an 18 word Scheme vector composed of the same items. */ *************** *** 241,246 **** --- 250,260 ---- return( rusagevector( &gcru ) ); } + #else + #define getrusage(x,y) /* no operation */ + #define updategcru() /* no operation */ + #endif /* SYSV-BSD dependency */ + /* Errors detected during garbage collection are logged by the following procedure. If any errors occur, the program will abort after logging them. More than 30 errors will result in the program being aborted at *************** *** 348,354 **** pp = STACKPTR; while (pp != sc_stackbase) move_continuation_ptr( *pp++ ); } ! #endif TITAN #ifdef VAX /* The following code is used to read the stack pointer. The register --- 362,368 ---- pp = STACKPTR; while (pp != sc_stackbase) move_continuation_ptr( *pp++ ); } ! #endif /* TITAN */ #ifdef VAX /* The following code is used to read the stack pointer. The register *************** *** 374,380 **** pp = STACKPTR; while (pp != sc_stackbase) move_continuation_ptr( *pp++ ); } ! #endif VAX #ifdef MIPS /* The following code is used to read the stack pointer. The register --- 388,394 ---- pp = STACKPTR; while (pp != sc_stackbase) move_continuation_ptr( *pp++ ); } ! #endif /* VAX */ #ifdef MIPS /* The following code is used to read the stack pointer. The register *************** *** 400,408 **** pp = STACKPTR; while (pp != sc_stackbase) move_continuation_ptr( *pp++ ); } ! #endif MIPS /* The size of an extended object in words is returned by the following function. */ --- 414,532 ---- pp = STACKPTR; while (pp != sc_stackbase) move_continuation_ptr( *pp++ ); } ! #endif /* MIPS */ + #ifdef APOLLO + /* The following code is used to read the stack pointer. The register + number is passed in to force an argument to be on the stack, which in + turn can be used to find the address of the top of stack. + */ + int *sc_processor_register( reg ) + int reg; + { + return( ® ); + } + + /* All processor registers that might contain pointers are traced by the + following procedure. + */ + + static trace_stack_and_registers() + { + int i, a1toa4_d0tod7[12], *pp; + + sc_regs( a1toa4_d0tod7 ); + pp = STACKPTR; + while (pp != sc_stackbase) move_continuation_ptr( *pp++ ); + } + #endif /* APOLLO */ + + #ifdef PRISM + /* All processor registers that might contain pointers are traced by the + following procedure. + */ + + static trace_stack_and_registers() + { + int i, regs[12], *pp; + + sc_regs( regs ); + pp = STACKPTR; + while (pp != sc_stackbase) move_continuation_ptr( *pp++ ); + } + #endif /* PRISM */ + + #ifdef SPARC + /* All processor registers which might contain pointers are traced by the + following procedure. + */ + + static trace_stack_and_registers() + { + int i, *pp; + jmp_buf tmp; + + pp = STACKPTR; + while (pp != sc_stackbase) move_continuation_ptr( *pp++ ); + } + #endif SPARC + + #ifdef SUN3 + /* The following code is used to read the stack pointer. The register + number is passed in to force an argument to be on the stack, which in + turn can be used to find the address of the top of stack. + */ + + int *sc_processor_register( reg ) + int reg; + { + return( ®+1 ); + } + + /* All processor registers which might contain pointers are traced by the + following procedure. + */ + + static trace_stack_and_registers() + { + int i, a2to5d2to7[10], *pp; + + sc_a2to5d2to7( a2to5d2to7 ); + pp = STACKPTR; + while (pp != sc_stackbase) move_continuation_ptr( *pp++ ); + } + #endif SUN3 + + + #ifdef I386 + /* The following code is used to read the stack pointer. The register + number is passed in to force an argument to be on the stack, which in + turn can be used to find the address of the top of stack. + */ + + int *sc_processor_register( reg ) + int reg; + { + return( ® ); + } + + /* All processor registers which might contain pointers are traced by the + following procedure. + */ + + static trace_stack_and_registers() + { + int i, *pp; + jmp_buf tmp; + + setjmp(tmp); + pp = STACKPTR; + while (pp != sc_stackbase) move_continuation_ptr( *pp++ ); + } + #endif I386 + + /* The size of an extended object in words is returned by the following function. */ *************** *** 1421,1426 **** --- 1545,1551 ---- getrusage( 0, &stopru ); updategcru(); if (sc_gcinfo) { + #ifndef SYSV fprintf( stderr, " %d%% locked %d%% retained %d user ms", (sc_lockcnt*100)/sc_heappages, *************** *** 1430,1435 **** --- 1555,1566 ---- " %d system ms %d page faults\n", stopru.ru_stime.tv_sec*1000+stopru.ru_stime.tv_usec/1000, stopru.ru_majflt ); + #else + fprintf( stderr, + " %d%% locked %d%% retained\n", + (sc_lockcnt*100)/sc_heappages, + (sc_generationpages*100)/sc_heappages); + #endif } if (sc_gcinfo == 2) { /* Perform additional consistency checks */ *************** *** 1663,1670 **** --- 1794,1805 ---- the Scheme object with that value. */ + #ifdef PRISM + TSCP sc_makefloat32( float value ) + #else TSCP sc_makefloat32( value ) float value; + #endif { SCP pp; *************** *** 1673,1679 **** pp = sc_extobjp; sc_extobjp = (SCP)(((int*)sc_extobjp)+FLOAT32SIZE); sc_extobjwords = sc_extobjwords-FLOAT32SIZE; ! pp->unsi.gned = FLOAT32TAG; } else pp = sc_allocateheap( FLOAT32SIZE, FLOAT32TAG, 0 ); --- 1808,1815 ---- pp = sc_extobjp; sc_extobjp = (SCP)(((int*)sc_extobjp)+FLOAT32SIZE); sc_extobjwords = sc_extobjwords-FLOAT32SIZE; ! pp->float32.tag = FLOAT32TAG; ! pp->float32.rest = 0; } else pp = sc_allocateheap( FLOAT32SIZE, FLOAT32TAG, 0 ); *************** *** 1685,1694 **** --- 1821,1840 ---- /* 64-bit floating point numbers are constructed by the following function. It is called with a 64-bit floating point value and it returns a pointer to the Scheme object with that value. + + On the Apollo Prism, it is vital that we use a function prototype, + so the compiler knows that the function's argument is being passed + in a register. Without the prototype, the argument is read from + the stack. See prism.asm for examples where it is simpler to pass + the argument in a register. Also see objects.h for the declaration. */ + #ifdef PRISM + TSCP sc_makefloat64( double value ) + #else TSCP sc_makefloat64( value ) double value; + #endif { SCP pp; *************** *** 1698,1704 **** pp = sc_extobjp; sc_extobjp = (SCP)(((int*)sc_extobjp)+FLOAT64SIZE); sc_extobjwords = sc_extobjwords-FLOAT64SIZE; ! pp->unsi.gned = FLOAT64TAG; } else pp = sc_allocateheap( FLOAT64SIZE, FLOAT64TAG, 0 ); --- 1844,1851 ---- pp = sc_extobjp; sc_extobjp = (SCP)(((int*)sc_extobjp)+FLOAT64SIZE); sc_extobjwords = sc_extobjwords-FLOAT64SIZE; ! pp->float64.tag = FLOAT64TAG; ! pp->float64.rest = 0; } else pp = sc_allocateheap( FLOAT64SIZE, FLOAT64TAG, 0 ); *** /tmp/,RCSt1a27386 Fri Nov 9 17:26:09 1990 --- scrt/heap.h Fri Nov 9 14:06:04 1990 *************** *** 42,51 **** --- 42,70 ---- /* Import definitions */ #ifndef rusage + + #ifdef apollo + #include + #else + #ifdef SPARC + #include + #else + #ifdef SUN3 + #include + #else + #ifndef SYSV #include + #endif + #endif + #endif + #endif + + #ifndef SYSV #include #endif + #endif + /* This module implements the object storage storage system for SCHEME->C. Unlike most Lisp systems, it is not intended that SCHEME->C provide a *************** *** 318,323 **** --- 337,363 ---- #ifdef VAX #define STACKPTR sc_processor_register( 14 ) + #endif + + #ifdef APOLLO + #define STACKPTR sc_processor_register( 7 ) + #endif + + #ifdef PRISM + extern int* prism_stack_frame(void); + #define STACKPTR prism_stack_frame() + #endif + + #ifdef I386 + #define STACKPTR sc_processor_register( 4 ) + #endif + + #ifdef SPARC + #define STACKPTR sc_processor_register( 0 ) + #endif + + #ifdef SUN3 + #define STACKPTR sc_processor_register( 15 ) #endif /* Some objects require cleanup actions when they are freed. For example, No differences encountered *** /tmp/,RCSt1a27395 Fri Nov 9 17:26:13 1990 --- scrt/makefile-tail Fri Nov 9 14:06:07 1990 *************** *** 34,40 **** scqquote.sc screp.sc \ scrt1.sc scrt2.sc scrt3.sc scrt4.sc scrt5.sc scrt6.sc scrt7.sc ! Smisc = GGC.c GGC.h GGCprivate.h mips.s predef.sc repdef.sc sci.sc sci.c vax.s ${Sruntimec} sci.c: ${predef.sc} ${objects.h} --- 34,41 ---- scqquote.sc screp.sc \ scrt1.sc scrt2.sc scrt3.sc scrt4.sc scrt5.sc scrt6.sc scrt7.sc ! Smisc = GGC.c GGC.h GGCprivate.h apollo.asm prism.asm mips.s predef.sc \ ! repdef.sc sci.sc sci.c vax.s sparc.s i386.s sun3.s sparc-pragma.h ${Sruntimec} sci.c: ${predef.sc} ${objects.h} *************** *** 49,54 **** --- 50,60 ---- .c.u: ${CC} -j -D${cpu} -I. $*.c + # Apollo assembler + .asm.o: + $(ASM) $* $(AFLAGS) + -mv $*.bin $*.o + .s.o: ${CC} -c $*.s *************** *** 69,75 **** -lm GGCi: ${Sruntimec} ${Sruntime} ${Aruntime} GGC.o sci.c sci.o ! make "CFLAGS = -DGGC ${CFLAGS}" GGCheap.o GGCscinit.o ${CC} -o GGCi ${CFLAGS} ${Sruntime} ${GGCCruntime} ${Aruntime} sci.o \ -lXaw -lXt -lX11 -lm --- 75,81 ---- -lm GGCi: ${Sruntimec} ${Sruntime} ${Aruntime} GGC.o sci.c sci.o ! $(MAKE) "CFLAGS = -DGGC ${CFLAGS}" GGCheap.o GGCscinit.o ${CC} -o GGCi ${CFLAGS} ${Sruntime} ${GGCCruntime} ${Aruntime} sci.o \ -lXaw -lXt -lX11 -lm *************** *** 78,84 **** mv Xlibsc.a libsc.a port: ! make "CC = ${CC}" "CFLAGS = ${CFLAGS}" "sccomp = echo" \ Xlibsc.a Xsci Xmv ${Plib} libsc_p.a: libsc.a --- 84,90 ---- mv Xlibsc.a libsc.a port: ! $(MAKE) "CC = ${CC}" "CFLAGS = ${CFLAGS}" "sccomp = echo" \ Xlibsc.a Xsci Xmv ${Plib} libsc_p.a: libsc.a *************** *** 85,91 **** mkdir saveobj mv ${Sruntime} ${Cruntime} ${Aruntime} saveobj rm -f libsc_p.a ! make "CC = ${CC}" "CFLAGS = ${CFLAGS} -pg" ${Sruntime} ${Cruntime} \ ${Aruntime} ar q libsc_p.a ${Cruntime} ${Sruntime} ${Aruntime} ranlib libsc_p.a --- 91,97 ---- mkdir saveobj mv ${Sruntime} ${Cruntime} ${Aruntime} saveobj rm -f libsc_p.a ! $(MAKE) "CC = ${CC}" "CFLAGS = ${CFLAGS} -pg" ${Sruntime} ${Cruntime} \ ${Aruntime} ar q libsc_p.a ${Cruntime} ${Sruntime} ${Aruntime} ranlib libsc_p.a *************** *** 127,133 **** rm -f sci libsc.a libsc_p.a srcdist: ! rdist -c README *.c *.h *.s *.sc makefile-tail ${destdir} bindist: rdist -c README makefile makefile-tail predef.sc objects.h \ --- 133,139 ---- rm -f sci libsc.a libsc_p.a srcdist: ! rdist -c README *.c *.h *.s *.sc *.asm makefile-tail ${destdir} bindist: rdist -c README makefile makefile-tail predef.sc objects.h \ *************** *** 134,140 **** libsc.a ${Plib} sci ${destdir} all: ! make "CC = ${CC}" "CFLAGS = ${CFLAGS}" "sccomp = ${sccomp}" \ Xlibsc.a Xsci Xmv ${Plib} srclinks: --- 140,146 ---- libsc.a ${Plib} sci ${destdir} all: ! $(MAKE) "CC = ${CC}" "CFLAGS = ${CFLAGS}" "sccomp = ${sccomp}" \ Xlibsc.a Xsci Xmv ${Plib} srclinks: *** /tmp/,RCSt1a27404 Fri Nov 9 17:26:15 1990 --- scrt/objects.c Thu Nov 1 08:05:03 1990 *************** *** 482,488 **** break; case EXTENDEDTAG: if (TX_U( p )->extendedobj.tag == FLOATTAG) ! return( (int)( TX_U( p )->FLOATUTYPE.value ) ); break; } sc_error( "TSCP_INT", "Argument cannot be converted to C int", 0 ); --- 482,488 ---- break; case EXTENDEDTAG: if (TX_U( p )->extendedobj.tag == FLOATTAG) ! return ROUND( FLOAT_VALUE( p ) ); break; } sc_error( "TSCP_INT", "Argument cannot be converted to C int", 0 ); *************** *** 506,514 **** if (TX_U( p )->extendedobj.tag == FLOATTAG) { v = TX_U( p )->FLOATUTYPE.value; if (v <= (double)(0x7fffffff)) ! return( (unsigned)( v ) ); else ! return( (unsigned)( v-((double)(0x40000000))*2.0 ) | 0x80000000 ); } break; --- 506,514 ---- if (TX_U( p )->extendedobj.tag == FLOATTAG) { v = TX_U( p )->FLOATUTYPE.value; if (v <= (double)(0x7fffffff)) ! return( (unsigned)ROUND( v ) ); else ! return( (unsigned)ROUND( v-((double)(0x40000000))*2.0 ) | 0x80000000 ); } break; *************** *** 543,551 **** case FLOATTAG: v = TX_U( p )->FLOATUTYPE.value; if (v <= (double)(0x7fffffff)) ! return( (unsigned)( v ) ); else ! return( (unsigned)( v-((double)(0x40000000))*2.0 ) | 0x80000000 ); break; } --- 543,551 ---- case FLOATTAG: v = TX_U( p )->FLOATUTYPE.value; if (v <= (double)(0x7fffffff)) ! return( (unsigned int)( v ) ); else ! return( (unsigned int)( v-((double)(0x40000000))*2.0 ) | 0x80000000 ); break; } *** /tmp/,RCSt1a27409 Fri Nov 9 17:26:19 1990 --- scrt/objects.h Fri Nov 9 14:06:14 1990 *************** *** 43,52 **** */ /* Default the value of CPUTYPE if not currently defined. */ - #ifndef MIPS #ifndef TITAN #ifndef VAX #ifdef mips #define MIPS 1 #endif --- 43,57 ---- */ /* Default the value of CPUTYPE if not currently defined. */ #ifndef MIPS #ifndef TITAN #ifndef VAX + #ifndef SPARC + #ifndef SUN3 + #ifndef I386 + #ifndef APOLLO + #ifndef PRISM + #ifdef mips #define MIPS 1 #endif *************** *** 56,65 **** --- 61,95 ---- #ifdef vax #define VAX 1 #endif + #ifdef sun + # ifdef sparc + # define SPARC 1 + # else + # ifdef mc68000 + # define SUN3 1 + # endif + # endif #endif + #ifdef i386 + #define I386 1 #endif + #ifdef apollo + # ifdef _ISP_A88K + # define PRISM 1 + # else + # define APOLLO 1 + # endif #endif + #endif /* PRISM */ + #endif /* APOLLO */ + #endif /* I386 */ + #endif /* SUN3 */ + #endif /* SPARC */ + #endif /* VAX */ + #endif /* TITAN */ + #endif /* MIPS */ + /* The Scheme->C installer may elect to have arithmetic overflow handled gracefully on either the MIPS or the VAX implementations. The default is to handle it. *************** *** 80,85 **** --- 110,116 ---- #ifdef TITAN #include #define CPUTYPE TITAN + #undef MATHTRAPS #endif #ifdef VAX *************** *** 96,101 **** --- 127,174 ---- #define CPUTYPE VAX #endif + #ifdef APOLLO + #include + #define CPUTYPE APOLLO + #define BIG_ENDIAN + #endif + + #ifdef PRISM + /* Use our own setjmp/longjmp so we can make sure all the registers + are saved that need to be saved, namely, .10 through .23, + plus the signal mask, return PC, and PSWs. + + The layout of these registers in the array is described in prism.asm. + */ + typedef int jmp_buf[18]; + #define CPUTYPE PRISM + #define BIG_ENDIAN + #endif + + #ifdef SPARC + typedef int jmp_buf[2+7+8+8+1]; + #define DOUBLE_ALIGN 1 + #define CPUTYPE SPARC + #define BIG_ENDIAN + #undef MATHTRAPS + #define MATHTRAPS 0 + #endif + + #ifdef SUN3 + #include + #define CPUTYPE SUN3 + #define BIG_ENDIAN + #undef MATHTRAPS + #define MATHTRAPS 0 + #endif + + #ifdef I386 + #include + #define CPUTYPE I386 + #undef MATHTRAPS + #define MATHTRAPS 0 + #endif + /* The data encoding scheme is similar to that used by Vax NIL and T, where all objects are represented by 32-bit pointers, with a "low tag" encoded in the two least significant bits encoding the type. All objects are *************** *** 123,128 **** --- 196,219 ---- struct STACKTRACE; + /* + Ugly, but machine independent way to declare and use bit fields: + Bit fields are declared using F?(...), where the least significant + fields are listed first (in honor of the original implementations). + Similarly, static objects are created with the U?(...) macros. + */ + #ifdef BIG_ENDIAN + #define F2(a,b) b;a + #define F3(a,b,c) c;b;a + #define U2(a,b) (b),(a) + #define U3(a,b,c) (c),(b),(a) + #else + #define F2(a,b) a;b + #define F3(a,b,c) a;b;c + #define U2(a,b) (a),(b) + #define U3(a,b,c) (a),(b),(c) + #endif + typedef char *TSCP; typedef union SCOBJ { /* SCHEME to C OBJECT */ *************** *** 130,141 **** unsigned gned; } unsi; struct { /* EXTENDEDOBJ */ ! unsigned tag:8; ! unsigned rest:24; } extendedobj; struct { /* SYMBOL */ ! unsigned tag:8; ! unsigned rest:24; TSCP name; TSCP *ptrtovalue; TSCP value; --- 221,232 ---- unsigned gned; } unsi; struct { /* EXTENDEDOBJ */ ! F2(unsigned tag:8, ! unsigned rest:24); } extendedobj; struct { /* SYMBOL */ ! F2(unsigned tag:8, ! unsigned rest:24); TSCP name; TSCP *ptrtovalue; TSCP value; *************** *** 142,172 **** TSCP propertylist; } symbol; struct { /* STRING */ ! unsigned tag:8; ! unsigned length:24; char char0; } string; struct { /* VECTOR */ ! unsigned tag:8; ! unsigned length:24; TSCP element0; } vector; struct { /* PROCEDURE */ ! unsigned tag:8; ! unsigned required:8; ! unsigned optional:16; TSCP (*code)(); TSCP closure; } procedure; struct { /* CLOSURE */ ! unsigned tag:8; ! unsigned length:24; TSCP closure; TSCP var0; } closure; struct { /* CONTINUATION */ ! unsigned tag:8; ! unsigned length:24; TSCP continuation; jmp_buf savedstate; int *address; --- 233,263 ---- TSCP propertylist; } symbol; struct { /* STRING */ ! F2(unsigned tag:8, ! unsigned length:24); char char0; } string; struct { /* VECTOR */ ! F2(unsigned tag:8, ! unsigned length:24); TSCP element0; } vector; struct { /* PROCEDURE */ ! F3(unsigned tag:8, ! unsigned required:8, ! unsigned optional:16); TSCP (*code)(); TSCP closure; } procedure; struct { /* CLOSURE */ ! F2(unsigned tag:8, ! unsigned length:24); TSCP closure; TSCP var0; } closure; struct { /* CONTINUATION */ ! F2(unsigned tag:8, ! unsigned length:24); TSCP continuation; jmp_buf savedstate; int *address; *************** *** 174,196 **** int word0; } continuation; struct { /* FLOAT32 */ ! unsigned tag:8; ! unsigned rest:24; float value; } float32; struct { /* FLOAT64 */ ! unsigned tag:8; ! unsigned rest:24; double value; } float64; struct { /* FORWARD */ ! unsigned tag:8; ! unsigned length:24; TSCP forward; } forward; struct { /* WORDALIGN */ ! unsigned tag:8; ! unsigned length:24; } wordalign; struct { /* PAIR */ TSCP car; --- 265,287 ---- int word0; } continuation; struct { /* FLOAT32 */ ! F2(unsigned tag:8, ! unsigned rest:24); float value; } float32; struct { /* FLOAT64 */ ! F2(unsigned tag:8, ! unsigned rest:24); double value; } float64; struct { /* FORWARD */ ! F2(unsigned tag:8, ! unsigned length:24); TSCP forward; } forward; struct { /* WORDALIGN */ ! F2(unsigned tag:8, ! unsigned length:24); } wordalign; struct { /* PAIR */ TSCP car; *************** *** 220,225 **** --- 311,332 ---- #define TX_U( tscp ) ((SCP)((char*)tscp-EXTENDEDTAG)) #define TP_U( tscp ) ((SCP)((char*)tscp-PAIRTAG)) #endif + #ifdef apollo + #define TX_U( tscp ) ((SCP)((char*)tscp-EXTENDEDTAG)) + #define TP_U( tscp ) ((SCP)((char*)tscp-PAIRTAG)) + #endif + #ifdef SPARC + #define TX_U( tscp ) ((SCP)((char*)tscp-EXTENDEDTAG)) + #define TP_U( tscp ) ((SCP)((char*)tscp-PAIRTAG)) + #endif + #ifdef SUN3 + #define TX_U( tscp ) ((SCP)((char*)tscp-EXTENDEDTAG)) + #define TP_U( tscp ) ((SCP)((char*)tscp-PAIRTAG)) + #endif + #ifdef I386 + #define TX_U( tscp ) ((SCP)((char*)tscp-EXTENDEDTAG)) + #define TP_U( tscp ) ((SCP)((char*)tscp-PAIRTAG)) + #endif /* Fixed point numbers are encoded in the address portion of the pointer. The value is obtained by arithmetically shifting the pointer value two bits to *************** *** 626,633 **** --- 733,768 ---- When the procedure is exited, sc_stacktrace is restored. In order to assure that sc_stacktrace always points to a valid entry, the list is maintained by subroutines (compilers want to optimize it out!). + + In dobacktrace(), the stack is traced by calling C-UNSIGNED-REF + to get the prevstacktrace pointer. The problem with this is that + C-UNSIGNED-REF (aka scrt4_c_2dunsigned_2dref) uses MUNSIGNED, which + uses T_U, which masks out the least significant two bits of the pointer. + The trick is to get an implementation independent method of aligning + the stacktrace structure. Most compilers at least align the structure + with an even address, but only some will align it on a four-byte boundary. + + The macro ALIGN4(t,x) declares "x" to be a pointer to "t", aligned on + a 4-byte boundary. If nothing special needs to be done, then the default + definition can be used. */ + #ifdef APOLLO + /* On an Apollo, things are usually aligned properly on the stack, + but after an interrupt, things can get screwy, and even doubles + can end up non-longword aligned. To be safe, we need to align + everything on a longword boundary ourselves. + */ + #define IDENT(a) a + #define CAT(a,b) IDENT(a)b + #define ALIGN4(t,x) char CAT(x,buf)[sizeof(t) + sizeof(long)];\ + t& x = * (t*) ((unsigned)CAT(x,buf) & ~(sizeof(long)-1)) + #endif + + /* the rest of the world does not need to worry about such matters */ + #ifndef ALIGN4 + #define ALIGN4(t,x) t x + #endif struct STACKTRACE { /* Stack trace back record */ struct STACKTRACE* prevstacktrace; TSCP procname; *************** *** 636,642 **** extern struct STACKTRACE *sc_stacktrace; ! #define PUSHSTACKTRACE( procedure ) struct STACKTRACE st; \ sc_pushtrace( &st, (procedure) ) #define POPSTACKTRACE( exp ) return( sc_poptrace( &st, (exp) ) ) --- 771,777 ---- extern struct STACKTRACE *sc_stacktrace; ! #define PUSHSTACKTRACE( procedure ) ALIGN4(struct STACKTRACE, st); \ sc_pushtrace( &st, (procedure) ) #define POPSTACKTRACE( exp ) return( sc_poptrace( &st, (exp) ) ) *************** *** 735,740 **** --- 870,887 ---- #ifdef VAX #define VECTOR_ELEMENT( tscp, n ) (*((PATSCP)(((char*)( tscp ))+3+((int)n)))) #endif + #ifdef apollo + #define VECTOR_ELEMENT( tscp, n ) (*((PATSCP)(((char*)( tscp ))+3+((int)n)))) + #endif + #ifdef SPARC + #define VECTOR_ELEMENT( tscp, n ) (*((PATSCP)(((char*)( tscp ))+3+((int)n)))) + #endif + #ifdef I386 + #define VECTOR_ELEMENT( tscp, n ) (*((PATSCP)(((char*)( tscp ))+3+((int)n)))) + #endif + #ifdef SUN3 + #define VECTOR_ELEMENT( tscp, n ) (*((PATSCP)(((char*)( tscp ))+3+((int)n)))) + #endif #define PROCEDURE_REQUIRED( tscp ) (TX_U( tscp )->procedure.required) #define PROCEDURE_OPTIONAL( tscp ) (TX_U( tscp )->procedure.optional) *************** *** 753,768 **** /* C declarations */ #define DEFSTRING( name, chars, len ) \ ! static struct { unsigned tag:8; \ ! unsigned length:24; \ char char0[len+(4-(len % 4))]; } \ ! name = { STRINGTAG, len, chars } #define DEFFLOAT( name, value ) \ ! static struct { unsigned tag:8; \ ! unsigned length: 24; \ FLOATTYPE f; } \ ! name = { FLOATTAG, 0, value } #define DEFTSCP( name ) TSCP name --- 900,915 ---- /* C declarations */ #define DEFSTRING( name, chars, len ) \ ! static struct { F2(unsigned tag:8, \ ! unsigned length:24); \ char char0[len+(4-(len % 4))]; } \ ! name = { U2(STRINGTAG, len), chars } #define DEFFLOAT( name, value ) \ ! static struct { F2(unsigned tag:8, \ ! unsigned length: 24); \ FLOATTYPE f; } \ ! name = { U2(FLOATTAG, 0), value } #define DEFTSCP( name ) TSCP name *************** *** 857,870 **** /* C operators that detect integer overflow in some implementations */ ! #if (MATHTRAPS == 0 || CPUTYPE == TITAN) #define IPLUS( a, b ) (a + b) #define IDIFFERENCE( a, b ) (a - b) #define INEGATE( a ) (- a) #define ITIMES( a, b ) (a * b) - #endif ! #if (MATHTRAPS && (CPUTYPE == MIPS || CPUTYPE == VAX)) #define IPLUS( a, b ) sc_iplus( a, b ) #define IDIFFERENCE( a, b ) sc_idifference( a, b ) #define ITIMES( a, b ) sc_itimes( a, b ) --- 1004,1017 ---- /* C operators that detect integer overflow in some implementations */ ! #if (MATHTRAPS == 0 || CPUTYPE == TITAN) #define IPLUS( a, b ) (a + b) #define IDIFFERENCE( a, b ) (a - b) #define INEGATE( a ) (- a) #define ITIMES( a, b ) (a * b) ! #else ! #define IPLUS( a, b ) sc_iplus( a, b ) #define IDIFFERENCE( a, b ) sc_idifference( a, b ) #define ITIMES( a, b ) sc_itimes( a, b ) *************** *** 895,910 **** significant 8 bits of the extended object header. */ ! #define UNKNOWNCALL( proc, argc ) (sc_unknownargc = argc, \ ! sc_unknownproc[ 1 ] = proc, \ ! sc_unknownproc[ \ ! (UNSI_GNED( \ ! sc_unknownproc[ TSCPTAG( proc ) ] ) \ ! == (argc*256+PROCEDURETAG)) ]) /* Inline type conversions */ ! #define FLT_FIX( flt ) C_FIXED( (int)(FLOAT_VALUE( flt )) ) #define FIX_FLT( fix ) MAKEFLOAT( (FLOATTYPE)(FIXED_C( fix )) ) #define FIX_FLTV( fix ) ((FLOATTYPE)(FIXED_C( fix ))) #define FLTV_FLT( flt ) MAKEFLOAT( flt ) --- 1042,1073 ---- significant 8 bits of the extended object header. */ ! #define UNKNOWNCALL( proc, argc ) \ ! (sc_unknownargc = argc, sc_unknownproc[ 1 ] = proc, \ ! sc_unknownproc[(PROCEDURE_REQUIRED(sc_unknownproc[ TSCPTAG(proc) ]) == argc\ ! && ! PROCEDURE_OPTIONAL(sc_unknownproc[ TSCPTAG( proc )]))]) ! /* UNSI_GNED(sc_unknownproc[ TSCPTAG( proc ) ] ) \ ! == (argc*256+PROCEDURETAG)) ]) ! */ /* Inline type conversions */ ! /* round a floating point number to the nearest integer */ ! #ifdef apollo ! #include ! /* Apollo SR10.2, with cc 6.7: rint() returns a bogus value (e.g., 0.9 ! is "rounded" to 0.899902). ! If Apollo does not fix rint() soon, then we should write our own. ! */ ! #define rint(x) floor((x) + 0.5) ! #define ROUND(x) ((int) rint(x)) ! #endif ! ! #ifndef ROUND ! #define ROUND(x) ((int) (x)) ! #endif ! ! #define FLT_FIX( flt ) C_FIXED( ROUND(FLOAT_VALUE( flt )) ) #define FIX_FLT( fix ) MAKEFLOAT( (FLOATTYPE)(FIXED_C( fix )) ) #define FIX_FLTV( fix ) ((FLOATTYPE)(FIXED_C( fix ))) #define FLTV_FLT( flt ) MAKEFLOAT( flt ) *************** *** 953,960 **** --- 1116,1132 ---- definitions needed by a SCHEME->C program. */ + #ifdef PRISM + /* As explained in heap.c, it is important to declare the function prototype, + so the compiler passes the floating point argument in a register, rather + than on the stack. + */ + extern TSCP sc_makefloat32(float); + extern TSCP sc_makefloat64(double); + #else extern TSCP sc_makefloat32(); extern TSCP sc_makefloat64(); + #endif extern TSCP sc_cons(); extern int sc_unknownargc; extern TSCP sc_unknownproc[ 4 ]; *** /tmp/,RCSt1a27478 Fri Nov 9 17:26:44 1990 --- scrt/scinit.c Fri Nov 9 14:06:20 1990 *************** *** 70,78 **** #include #define STACKBASE (int*)USRSTACK #endif - #include #include #include #include #include --- 70,106 ---- #include #define STACKBASE (int*)USRSTACK #endif + #ifdef apollo + #define ETEXT ((int)&etext) /* First address after text */ + #include + /* the stack back moves depending on shared libraries */ + #include + #include + #include + static proc2_$info_t sc_apollo_proc2; + #define STACKBASE ((int*) sc_apollo_proc2.stack_base) + #endif + #ifdef SPARC + #define ETEXT ((int)&etext) /* First address after text */ + #include + #define STACKBASE (int*)USRSTACK + #endif + #ifdef SUN3 + #define ETEXT ((int)&etext) /* First address after text */ + #include + #include + #define STACKBASE (int*)USRSTACK + #endif + #ifdef ISC386IX + #define ETEXT ((int)&etext) /* First address after text */ + #include + #include /* probably should be elsewhere */ + #include + #define STACKBASE (int*)UVSTACK + #endif #include + #include #include #include #include *************** *** 96,103 **** /* Global data structure for this module. */ ! static int emptyvector = VECTORTAG, ! emptystring[2] = {STRINGTAG, 0}; FILE *sc_stdin, /* Standard I/O Subroutine FILE pointers */ *sc_stdout, --- 124,135 ---- /* Global data structure for this module. */ ! /* this struct must look like an SCOBJ */ ! static struct ! { ! F2(unsigned tag:8, ! unsigned length:24); ! } emptyvector, emptystring[2]; FILE *sc_stdin, /* Standard I/O Subroutine FILE pointers */ *sc_stdout, *************** *** 183,188 **** --- 215,221 ---- static init_procs() { + #ifndef SYSV INITIALIZEVAR( U_TX( ADR( t1030 ) ), ADR( sc_my_2drusage_v ), MAKEPROCEDURE( 0, *************** *** 192,197 **** --- 225,231 ---- MAKEPROCEDURE( 0, 0, sc_collect_2drusage, EMPTYLIST ) ); + #endif INITIALIZEVAR( U_TX( ADR( t1034 ) ), ADR( sc_collect_v ), MAKEPROCEDURE( 0, *************** *** 288,293 **** --- 322,340 ---- char *freebase; TSCP unknown; + #ifdef apollo + /* on an apollo, we get the stack top at run time */ + uid_$t me; + status_$t status; + proc2_$who_am_i(&me); + proc2_$get_info(me, &sc_apollo_proc2, sizeof(sc_apollo_proc2), &status); + if (status.all != status_$ok && status.all != proc2_$is_current) + { + error_$print(status); + exit(2); + } + #endif + if (sc_gcinfo) fprintf( stderr, "***** SCGCINFO = %d SCHEAP = %d SCLIMIT = %d\n", sc_gcinfo, scheap, sclimit ); *************** *** 319,324 **** --- 366,373 ---- sc_mutex = 0; sc_pendingsignals = 0; sc_emptylist = EMPTYLIST; + emptyvector.tag = VECTORTAG; + emptystring[0].tag = STRINGTAG; sc_emptyvector = U_T( &emptyvector, EXTENDEDTAG ); sc_emptystring = U_T( emptystring, EXTENDEDTAG ); sc_falsevalue = FALSEVALUE; *************** *** 557,562 **** --- 606,617 ---- if (scheap < save.heappages/(ONEMB/PAGEBYTES)) scheap = save.heappages/(ONEMB/PAGEBYTES); if (sclimit < save.limit) sclimit = save.limit; + #ifdef sun + /* in SunOS, stderr is line buffered, which causes some unwanted */ + /* malloc.. */ + if (sc_gcinfo) + setbuf(stderr, (char*)0); + #endif if (sc_gcinfo) fprintf( stderr, "***** SCGCINFO = %d SCHEAP = %d SCLIMIT = %d\n", sc_gcinfo, scheap, sclimit ); *************** *** 602,607 **** --- 657,664 ---- sc_mutex = 0; sc_pendingsignals = 0; sc_emptylist = EMPTYLIST; + emptyvector.tag = VECTORTAG; + emptystring[0].tag = STRINGTAG; sc_emptyvector = U_T( &emptyvector, EXTENDEDTAG ); sc_emptystring = U_T( emptystring, EXTENDEDTAG ); sc_falsevalue = FALSEVALUE; *************** *** 702,707 **** --- 759,765 ---- scrt6_error( sc_string_2d_3esymbol( sc_cstringtostring( symbol ) ), sc_cstringtostring( format ), scrt1_reverse( argl ) ); + va_end( argp ); } /* The following function returns informations about the implementation. The *************** *** 730,735 **** --- 788,806 ---- #ifdef VAX sc_cstringtostring( "VAX" ), #endif + #ifdef apollo + sc_cstringtostring( "Apollo" ), + #endif + #ifdef SPARC + sc_cstringtostring( "Sun4/SPARC" ), + #endif + #ifdef SUN3 + sc_cstringtostring( "Sun3" ), + #endif + #ifdef I386 + sc_cstringtostring( "AT/386" ), + #endif + sc_cons( #ifdef MIPS sc_cstringtostring( "R2000" ), *************** *** 740,747 **** --- 811,853 ---- #ifdef VAX sc_cstringtostring( "VAX" ), #endif + #ifdef APOLLO + sc_cstringtostring( "68K" ), + #endif + #ifdef PRISM + sc_cstringtostring( "PRISM" ), + #endif + #ifdef SPARC + sc_cstringtostring( "SPARC" ), + #endif + #ifdef SUN3 + sc_cstringtostring( "68K" ), + #endif + #ifdef I386 + sc_cstringtostring( "Intel 386" ), + #endif sc_cons( + #ifdef apollo + sc_cstringtostring( "Domain/OS" ), + #else /* ! apollo */ + #ifdef SPARC + #ifdef sun + sc_cstringtostring( "SunOS" ), + #else + sc_cstringtostring( "SparcOS" ), + #endif /* sun */ + #else /* ! SPARC */ + #ifdef SUN3 + sc_cstringtostring( "SunOS" ), + #else + #ifdef SYSV + sc_cstringtostring( "System V.3.2" ), + #else sc_cstringtostring( "ULTRIX" ), + #endif /* SYSV */ + #endif /* SUN3 */ + #endif /* SPARC */ + #endif /* apollo */ sc_cons( FALSEVALUE, EMPTYLIST *** /tmp/,RCSt1a27560 Fri Nov 9 17:27:16 1990 --- scrt/signal.c Fri Nov 9 14:06:25 1990 *************** *** 49,54 **** --- 49,57 ---- #include "apply.h" #include "signal.h" #include "/usr/include/signal.h" + #ifdef apollo + #include + #endif extern TSCP scrt4_onsignal2(); *************** *** 118,124 **** --- 121,131 ---- } else { /* Signal must be defered */ + #ifdef SYSV + sighold( signal ); + #else sigblock( 1<C + * + * This file implements the assembly language part of the Apollo port, + * specifically for the DN3000 and DN4000 series, that is, depending on + * the M68020 CPU and M68881 FPP. + * + * Included are all the necessary math routines to catch integer overflow. + * + * This file is written for PIC (Position Independent Code), to build + * a shared library. + * + * Ray Lischner (uunet!mntgfx!lisch) + * 26 April 1990 + + module sc_apollo + cpu 68020,68881 + sri 68020 + + entry sc_setregs + entry sc_regs + entry sc_iplus + entry sc_idifference + entry sc_inegate + entry sc_itimes + + data + + * set up jump tables for calling PIC routines + data_start equ * + + sc_iplus lea data_start,a0 + jmp.l sc$iplus + sc_idifference lea data_start,a0 + jmp.l sc$idifference + sc_inegate lea data_start,a0 + jmp.l sc$inegate + sc_itimes lea data_start,a0 + jmp.l sc$itimes + + * set up transfer address for external PIC routines + extern sc_makefloat64 + sc$makefloat64 ac sc_makefloat64 + + text + + *********************************************************************** + * void sc_setregs(int* a6, int* a7) + * Apollo's longjmp() checks to see if the jump is backwards in the stack. + * If not, it assumes that something is wrong and ungracefully terminates + * the program. Since we don't want this to happen, we need to fake + * out Domain/OS. This is done by setting the stack pointer (a7) and + * frame pointer (a6) to the destination frame, thus circumventing + * longjmp's checks. + * + * To accomplish this takes some clever tricks. First, we need to know + * how the stack is layed out: + * + * (lower addresses) + * +----------------------------+ + * A7 | local storage ... | + * +----------------------------+ + * A6 | link to previous frame | + * +----------------------------+ + * | return address | + * +----------------------------+ + * | arguments pushed by caller | + * +----------------------------+ + * (higher addresses) + * Note that we are ignoring floating point control blocks. + * + * The caller pushes the desired values for A7 and A6. On entry to sc_setregs(), + * A6 points to the caller's frame, and A7 points to the return address. + * We can retrieve the caller's arguments by dereferencing a7: the second + * argument is in 8(a7), and the first is in 4(a7). We can just copy + * them into the registers we want, but first we need to save the return + * address before we lose the pointer to it. It is saved in A0, at the + * same time we load A6 and A7. Clever, isn't it? After getting the new + * register values, we know that the caller will try to pop the + * arguments off the stack by adding 8 to A7. We circumvent this by + * subtracting 8 now. + + sc_setregs procedure "sc_setregs",nocode + movem.l (a7),a0/a6-a7 + subq.l #8,a7 + jmp (a0) + + *********************************************************************** + * void sc_regs(int regs[12]) + * sc_regs returns the values of a1-a4, d0-d7 in the caller supplied buffer. + * These are the "callee" save registers that need to be examined during + * garbage collection. + + sc_regs procedure "sc_regs",#-4 + move.l 8(a6),a0 * a0 := ®s[0] + movem.l d0-d7/a1-a4,(a0) * save the interesting registers + return sc_regs + + *********************************************************************** + * The following routines are for doing arithmetic on tagged numbers. + * The input arguments are tagged integers, that is, integers shifted + * left by two bits. (Except for sc_itimes, where only the second + * argument, b, is shifted.) This makes it easier to check for overflow, + * but we must unshift the values before calling sc_makefloat64(). + * + * When the result of any operation overflows, the operands are converted + * to floating point, and the operation is repeated. The floating point + * result is then passed to sc_makefloat64() to produce a float object + * to return. + + * int sc_iplus(int a, int b) + * returns the integer sum, a + b, where a and b are the two + * integer arguments, unless integer overflow occurs, then returns + * (unsigned int) sc_makefloat64( (double)a + (double)b ) instead. + + sc$iplus procedure "sc_iplus",#0,a5 + move.l a0,a5 + * add the arguments + move.l 8(a6),d0 + move.l 12(a6),d1 + add.l d1,d0 + * if the operation overflows, we know to use floating point + bvc 1$ + + * otherwise, convert to floating point and add + move.l 8(a6),d0 + asr.l #2,d0 + fmove.l d0,fp0 + * note that d1 still contains "b" + asr.l #2,d1 + fmove.l d1,fp1 + fadd fp1,fp0 + * pass the floating point sum to sc_makefloat64 + fmove.d fp0,-(sp) + move.l sc$makefloat64,a0 + jsr (a0) + addq.l #8,sp + + 1$ return sc$iplus + + + * int sc_idifference(int a, int b) + * returns integer difference, a - b, where a and b are the two + * integer arguments, unless integer overflow occurs, then returns + * (unsigned int) sc_makefloat64( (double)a - (double)b ) instead. + * + + sc$idifference procedure "sc_idifference",#0,a5 + move.l a0,a5 + * subtract the arguments + move.l 8(a6),d0 + move.l 12(a6),d1 + sub.l d1,d0 + * if the operation overflows, we know to use floating point + bvc 1$ + + * otherwise, convert to floating point and subtract + move.l 8(a6),d0 + asr.l #2,d0 + fmove.l d0,fp0 + * note that d1 still contains "b" + asr.l #2,d1 + fmove.l d1,fp1 + fsub fp1,fp0 + * pass the floating point sum to sc_makefloat64 + fmove.d fp0,-(sp) + move.l sc$makefloat64,a0 + jsr (a0) + addq.l #8,sp + + 1$ return sc$idifference + + * int sc_inegate(int a) + * returns integer negation, -a, where a is the integer + * argument, unless integer overflow occurs, then returns + * (unsigned int) sc_makefloat64( -(double)a) instead. + * + + sc$inegate procedure "sc_inegate",#0,a5 + move.l a0,a5 + * negate the argument + move.l 8(a6),d0 + move.l d0,d1 + neg.l d0 + * if the operation overflows, we know to use floating point + bvc 1$ + + * otherwise, convert to floating point and negate + asr.l #2,d1 + fmove.l d1,fp1 + fneg fp1,fp0 + * pass the floating point sum to sc_makefloat64 + fmove.d fp0,-(sp) + move.l sc$makefloat64,a0 + jsr (a0) + addq.l #8,sp + + 1$ return sc$inegate + + * sc_itimes(int a, int b) + * returns integer procuct, a * b, where a and b are the two + * integer arguments, unless integer overflow occurs, then returns + * (unsigned int) sc_makefloat64( (double)a * (double)b ) instead. + * Unlike the previous arithmetic functions, only "b" has been shifted. + + sc$itimes procedure "sc_itimes",#0,a5 + move.l a0,a5 + * multiply the arguments + move.l 8(a6),d0 + move.l 12(a6),d1 + muls.l d1,d0 + + * if the operation overflows, we know to use floating point + bvc 1$ + + * otherwise, convert to floating point and multiply + fmove.l 8(a6),fp0 + * note that d1 still contains "b" + asr.l #2,d1 + fmove.l d1,fp1 + fmul fp1,fp0 + * pass the floating point sum to sc_makefloat64 + fmove.d fp0,-(sp) + move.l sc$makefloat64,a0 + jsr (a0) + addq.l #8,sp + + 1$ return sc$itimes + + end *** /dev/null Mon Nov 12 09:28:29 1990 --- scrt/apollo.o.uu Mon Nov 12 09:26:54 1990 *************** *** 0 **** --- 1,69 ---- + begin 444 apollo.o + M 9< "28WDLH DT '0 L@ X 0 ! #) "P @ + M 0 (?@ "YT97AT "!J @:@ $$ !J + M @ " N=6YW:6YD @JP (*L > JP B* + M ' @+F1A=&$ 0 $ "P + M( @"YB;&]C:W, $ + ! "P '@ #) "- 0 # N + M;&EN97, ! @P 0(, D@ !00 P +G-Y;6)O + M;', 0*> $"G@ I8 66 , "YR=V1I $% + M- !!30 X (+ "/@ 8 ! N;6ER + M &@ "&0 ( +G-R:0 P + M A^ " $S7P0!1CT[03E;__"!N A(T![_3EY.=4Y6 + M O#2I(("X ""(N S0@6@ "(@+@ (Y(#R $ Y('R 4" \@ $(O(G= @ + M;0 H3I!0CRIN__Q.7DYU3E8 "\-*D@@+@ ((BX #)"!: (B N CD@/( + M0 #D@?(!0(#R 0H\B=T "!M "A.D%"/*F[__$Y>3G5.5@ +PTJ2" N @B + M $2 : &.2!\@% @/( !!KR)W0 (&T *$Z04(\J;O_\3EY.=4Y6 O#2I( + M("X ""(N Q, 0@ : 'O(N0 ".2!\@% @/( !"/R)W0 (&T *$Z04(\J + M;O_\3EY.=0 "!J ! @0 !X @:@ @# @ + M @; ! ! /____P (' ^ 2 #____\ "!_@ /@$@ + M _____ @CP #(!( /____P ()N \ 2 #____\ 0 ! @ + M 4 !P #H : +@ > " $ $"# ! IX (&H $ , %* + M"O-, !*@0 5P @ / 0 "P ! 0 + M $ (" * $^ ( $ ( , $ 0! " + M @ "@ !(0 " * ! $ # " ! ' 0 @( H + M 0$ @ % 0 #X P !@ 0 "H$ (" * + M #B ( !X $ ^ , !6 $ !%! " @ "@ R0 " + M H ! ,@ # E ! 8 0 @( *P @ ,@ + M 0 #P P ,8 0 '@; (@O+VIE;&QI;W1T+VQO8V%L7W5S97(O + M9VYU+G-R8RYP ! "YL + M:6YE

6UB;VQS $" + MG@ & # 0 I8 "YR=V1I $%- ' # 0 + M #@ !@ "YM:7( ( # 0 !H + M "YSC + * + * This file implements the assembly language part of the Prism port, + * specifically for the DN10000. + * + * Included are all the necessary math routines to catch integer overflow. + * + * NOTE: Don't even try to read this file if you do not understand + * how an Apollo Prism (also called an AT, for Advanced Technology; + * perhaps Apollo thinks the Prism is as good as an IBM PC AT :-) works. + * I have tried to optimize the parallel operations, such as branch and + * call shadows, and combining integer and floating point operations. + * (The former are common; the latter are rare in this file.) + * + * The sematics of b.sa are completely different from b.sn, and the + * subtle differences are too lengthy to discuss here. Read the + * various Apollo manuals, such as the AT Assembler Reference and + * the AT Technical Reference. + * + * Apollo's setjmp/longjmp do not permit jumps to random locations in the + * stack, so we must write our own. On the DN3000 (M68K), we can get away + * with simply altering the stack and frame pointers (A6 and A7) before + * calling longjmp, but on the Prism this does not work because longjmp + * only jumps to a valid stack frame. I tried modifying call/cc to + * restore the stack and registers before calling longjmp(), but this + * does not work because it changes the data base register, which messes + * up the call to longjmp. The simplest solution is to reimplemen]t + * setjmp and longjmp. + * + * Another reason to write our own setjmp/longjmp is to make sure all + * the registers are saved properly. The standard jmp_buf does not have + * enough room to save all the needed registers. + * + * Ray Lischner (uunet!mntgfx!lisch) + * 1 May 1990 + + module sc_prism + + export.f prism_stack_frame + export.p sc_longjmp + export.f sc_setjmp + export.p sc_regs + export.f sc_iplus + export.f sc_idifference + export.f sc_inegate + export.f sc_itimes + + import.f sc_makefloat64 + import.f sigblock + import.f sigsetmask + + data + + * set up ECBs for all the functions that need one + data_frame equ * + + sc_setjmp procedure ok + .0 = sc$setjmp ; get the relocatable address of the routine + .1 = .sf ; save the old stack frame + .2 = #data_frame ; get the relocatable data frame + b.sa [.0] ; branch to the real routine + [--.sf,#16] = .1 ; push the old .SF onto the stack + + sc_longjmp procedure ok + .0 = sc$longjmp ; get the relocatable address of the routine + .1 = .sf ; save the old stack frame + .2 = #data_frame ; get the relocatable data frame + b.sa [.0] ; branch to the real routine + [--.sf,#16] = .1 ; push the old .SF onto the stack + + sc_idifference procedure ok + .0 = sc$idifference ; get the relocatable address of the routine + .1 = .sf ; save the old stack frame + .2 = #data_frame ; get the relocatable data frame + b.sa [.0] ; branch to the real routine + [--.sf,#16] = .1 ; push the old .SF onto the stack + + sc_inegate procedure ok + .0 = sc$inegate ; get the relocatable address of the routine + .1 = .sf ; save the old stack frame + .2 = #data_frame ; get the relocatable data frame + b.sa [.0] ; branch to the real routine + [--.sf,#16] = .1 ; push the old .SF onto the stack + + sc_iplus procedure ok + .0 = sc$iplus ; get the relocatable address of the routine + .1 = .sf ; save the old stack frame + .2 = #data_frame ; get the relocatable data frame + b.sa [.0] ; branch to the real routine + [--.sf,#16] = .1 ; push the old .SF onto the stack + + sc_itimes procedure ok + .0 = sc$itimes ; get the relocatable address of the routine + .1 = .sf ; save the old stack frame + .2 = #data_frame ; get the relocatable data frame + b.sa [.0] ; branch to the real routine + [--.sf,#16] = .1 ; push the old .SF onto the stack + + * jump table for the ECBs + sc$setjmp data.l sc$$setjmp + sc$longjmp data.l sc$$longjmp + sc$idifference data.l sc$$idifference + sc$inegate data.l sc$$inegate + sc$iplus data.l sc$$iplus + sc$itimes data.l sc$$itimes + + * relocation table for the external functions + sc$makefloat64 data.l sc_makefloat64 + sig$setmask data.l sigsetmask + sig$block data.l sigblock + proc + + *********************************************************************** + * int prism_stack_frame(void) + * Return the caller's stack frame pointer. See the STACKPTR macro + * in heap.h for how this is called. + + prism_stack_frame procedure ok + b.sa [.return] + .0 = .sf + + + *********************************************************************** + * int sc_setjmp(jmp_buf buf) + * Save the current signal mask, processor status words, and preserved + * registers in the caller-supplied buffer, and return zero. + + sc$$setjmp procedure name="sc_setjmp",return=save,stack=(),save=1$ + [.sf,4] = .4 + [.sf,8] = .return + [.sf,12] = .10 + .10 = .2 + using .10, data_frame + 1$ .0 = .ipsw ; and the processor status words + [.4++] = .0 + .0 = .fppsw + [.4++] = .0 + .0 = [.sf,12] ; old value of .10 + [.4++] = .0 + [.4++] = .11 + [.4++] = .12 + [.4++] = .13 + [.4++] = .14 + [.4++] = .15 + [.4++] = .16 + [.4++] = .17 + [.4++] = .18 + [.4++] = .19 + [.4++] = .20 + [.4++] = .21 + [.4++] = .return + .0 = [.sf] + [.4++] = .0 + + .3 = sig$block ; and the current signal mask + .return = call.sa [.3] ; sigblock(0) + .4 = .null + .4 = [.sf,4] + [.4++] = .0 + + .10 = [.sf,12] ; restore the saved registers + .return = [.sf,8] + .0 = .null + b.sa [.return] ; return(0) + .sf = [.sf] + + drop .10 + endp + + * void longjmp(jmp_buf buf, int rtn) + * Jump to the location saved by a previous call to setjmp(), such that + * it looks to the caller of setjmp() as though setjmp returned "rtn". + * If "rtn" is zero, one is returned. + + sc$$longjmp procedure name="sc_longjmp",return=save,stack=(),save=1$ + [.sf,8] = .return + using .2, data_frame + 1$ .cc = .5 + .0 = [.4++] + bnz.sf 2$ ; make sure the return value is non-zero + .5 = #1 + 2$ .ipsw = .0 + .0 = [.4++] + .fppsw = .0 + .10 = [.4++] + .11 = [.4++] + .12 = [.4++] + .13 = [.4++] + .14 = [.4++] + .15 = [.4++] + .16 = [.4++] + .17 = [.4++] + .18 = [.4++] + .19 = [.4++] + .20 = [.4++] + .21 = [.4++] + .0 = [.4++] + [.sf,8] = .0 ; save the return PC + .0 = [.4++] + [.sf] = .0 ; save .sf + [.sf,4] = .5 ; save return value + + .3 = sig$setmask ; restore the signal mask + .return = call.sa [.3] + .4 = [.4] + + .0 = [.sf,4] ; return the user-supplied "rtn" + .return = [.sf,8] + b.sa [.return] + .sf = [.sf] + endp + + *********************************************************************** + * void sc_regs(int regs[12]) + * sc_regs stores the values of .10 - .21 in the caller supplied buffer. + * These are the "callee" save registers that need to be examined during + * garbage collection. + + sc_regs procedure ok + [.4++] = .10 + [.4++] = .11 + [.4++] = .12 + [.4++] = .13 + [.4++] = .14 + [.4++] = .15 + [.4++] = .16 + [.4++] = .17 + [.4++] = .18 + [.4++] = .19 + [.4++] = .20 + b.sa [.return] + [.4] = .21 + endp + + *********************************************************************** + * The following routines are for doing arithmetic on tagged numbers. + * The input arguments are tagged integers, that is, integers shifted + * left by two bits. (Except for sc_itimes, where only the second + * argument, b, is shifted.) This makes it easier to check for overflow, + * but we must unshift the values before calling sc_makefloat64(). + * + * When the result of any operation overflows, the operands are converted + * to floating point, and the operation is repeated. The floating point + * result is then passed to sc_makefloat64() to produce a float object + * to return. + + + * int sc_iplus(int a, int b) + * returns the integer sum, a + b, where a and b are the two + * integer arguments, unless integer overflow occurs, then returns + * (unsigned int) sc_makefloat64( (double)a + (double)b ) instead. + + sc$$iplus procedure name="sc_iplus",return=save,stack=(),save=1$ + [.sf,8] = .return + * add the arguments + 1$ .0.cc = .4 + .5 ; try adding the arguments as integers + .4 = .4 SHRA #2 ; wait 1 cycle until CCs set + bnv.sf 2$ ; return if the integer operation worked + .5 = .5 SHRA #2 ; otherwise keep working + .fs0.i = .5 ; convert the integers to floating point + .fs1.i = .4 + .fd8 = float(.fs1.i) + .fd0 = float(.fs0.i) + * get ready to call makefloat64, while adding the operands + .3 = sc$makefloat64, .fd8 += .fd0 + .return = call.sn [.3] ; call sc_makefloat64() + nop + .return = [.sf,8] ; pop the return PC + + 2$ b.sa [.return] ; return + .sf = [.sf] ; restore the old .SF + endp + + + * int sc_idifference(int a, int b) + * returns integer difference, a - b, where a and b are the two + * integer arguments, unless integer overflow occurs, then returns + * (unsigned int) sc_makefloat64( (double)a - (double)b ) instead. + + sc$$idifference procedure ok,name="sc_idifference" + [.sf,8] = .return + * subtract the arguments + 1$ .0.cc = .4 - .5 ; try subtracting the arguments as integers + .4 = .4 SHRA #2 ; wait 1 cycle until CCs set + bnv.sf 2$ ; return if the integer operation worked + .5 = .5 SHRA #2 ; otherwise keep working + .fs0.i = .5 ; convert the integers to floating point + .fs1.i = .4 + .fd8 = float(.fs1.i) + .fd0 = float(.fs0.i) + * get ready to call makefloat64, while subtracting the operands + .3 = sc$makefloat64, .fd8 -= .fd0 + .return = call.sn [.3] ; call sc_makefloat64() + nop + .return = [.sf,8] ; pop the return PC + + 2$ b.sa [.return] ; return + .sf = [.sf] ; restore the old .SF + endp + + * int sc_inegate(int a) + * returns integer negation, -a, where a is the integer + * argument, unless integer overflow occurs, then returns + * (unsigned int) sc_makefloat64( -(double)a) instead. + + sc$$inegate procedure ok,name="sc_inegate" + [.sf,8] = .return + * negate the argument + 1$ .0.cc = -.4 ; try negating the argument as an integer + .4 = .4 SHRA #2 ; wait 1 cycle until CCs set + bnv.sf 2$ ; return if the integer operation worked + .fs0.i = .4 ; otherwise keep working + .fd8 = float(.fs0.i) ; convert the argument to floating point + * get ready to call makefloat64, while negating the argument + .3 = sc$makefloat64, .fd8 = -.fd8 + .return = call.sn [.3] ; call sc_makefloat64() + nop + .return = [.sf,8] ; pop the return PC + + 2$ b.sa [.return] ; return + .sf = [.sf] ; restore the old .SF + endp + + * sc_itimes(int a, int b) + * returns integer procuct, a * b, where a and b are the two + * integer arguments, unless integer overflow occurs, then returns + * (unsigned int) sc_makefloat64( (double)a * (double)b ) instead. + * Unlike the previous arithmetic functions, only "b" has been shifted. + * + * This is a pain on a Prism because we need to use the floating + * point unit for the integer multiply, and that means we cannot + * set the integer condition codes. Instead, we do a normal + * floating point multiply and explicitly check the result to see + * if it fits into an integer. If not, we divide by 4 to get the + * true result. Note that this does not affect the precision + * of the result. + + sc$$itimes procedure name="sc_itimes",return=save,stack=(),save=1$ + [.sf,8] = .return + 1$ .fs0.i = .4 ; load floating point registers for the + .fs1.i = .5 ; multiplication + .fd8 = float(.fs0.i) + .fd2 = float(.fs1.i) + * do the multiply; at the same time, load sc_makefloat64's address, to + * get ready for calling it, in case the multiply overflows + .3 = sc$makefloat64, .fd8 *= .fd2 + + * The floating point constants do not change, so we can put them in + * the shared text segment. Change the address base to .PC, so we + * use PC-relative addressing. + drop .2 + + * look for overflow by comparing with the maximum allowable integer + .fd2 = maxint ; get maxint + .fcc = .fd8 ? .fd2 + bfgt.sf 2$ ; see if the result fits into an integer + .fd2 = minint.fd + .fcc = .fd8 ? .fd2 + bflt.sf 2$ + + .fs0.i = round(.fd8) ; yes, so convert it to an integer + b.sa 3$ ; and return + .0 = .fs0.i + + 2$ .fd0 = four + .fd8 /= .fd0 ; get the real floating point value + .return = call.sn [.3] ; call sc_makefloat64() + nop + .return = [.sf,8] ; pop the return PC + + 3$ b.sa [.return] ; return + .sf = [.sf] ; restore the old .SF + + * constant value for the division, above + four data.fd 4.0 + + * maximum and minimum possible integer, for comparison, above + maxint data.fd 2147483644.0 + + * The assembler seems to ignore the sign of a floating point constant. + * A Prism uses IEEE format, so the smallest possible integer + * is pretty easy to write in hexadecimal. + *minint data.fd -2147483648.0 + minint data.q h'C1E00000, h'00000000 + endp + + end *** /dev/null Mon Nov 12 09:28:30 1990 --- scrt/prism.o.uu Mon Nov 12 09:26:39 1990 *************** *** 0 **** --- 1,82 ---- + begin 444 prism.o + M 90 ""8]YI@ K0 )0 L@ H 0 ! $R * ( + M$ "YT97AT @!@ ( 8 +8 !@ + M ! @ " N=6YW:6YD (!%@ " 18 < !%@ GX + M ' 0 @+F1A=&$ $ ! * 3( */@ "0 + M$ 0"YM:7( < %: @ N + M02!#X$$@0^)!($/D02!#YD$@0^A!($/J02!#P$$@1H%P (/ 02!&@7 + M !HMP $8&( E"+ -@A 8!< !&+7 @D, 68O< #E$$@0Y9!($.802 + M!#FD$@0YQ!($.>02!#H$$@0Z)!($.D02!#ID$@0ZA!($)# %FJD !JUP ( + M$ 1@!1""OT0MW /$**_1?R_ 0 Y $ _)\!! #D 023_P ?-CR 09/_ !\V + M/ X&( D#*,@@ BQ #$_\ 'V+7 @D, 68O< &K7 @0!&@%$(*_1"W< + M \0HK]%_+\! #D 0#\GP$$ .0!!)/_ !\V/(!!D_\ 'S8\ #@8@"0,IR" + M "+$ ,3_P ?8M< ""0P !9B]P :M< "! ?: 00@K]$K=P "P3$ #\GP$ + M .0! )/_ !\V/( X&( D#)<@@@BQ #$_\ 'V+7 @D, 68O< &K7 C\ + MGP$ .0! /R_ 00 Y $$D_\ 'S8\@ "3_P ?-CP@0>!B ) P3(("[#X < 3$ + M "3_P ?$[P" BJ< QL/@!DD_\ 'Q.\ @*K' (!,0 )/_ !\V' ((K# + M"P3$ #\'R$ .0! .P> "@$Q D_\ 'S ,@@ BQ #$_\ 'V+7 @D, 6 + M8O< ! $ $'?____ P> " &( %H! ' + M @!B 1@ @ _^V" ( A0 $( ( /_M@( " +, H " + M #_[8" @#' * _^P ( VP " /_L " .L !6 + M " #_[8" 8!X >! W(!\87O_X)# #@WE'!@'@!H$#<@'QA>_^0D, + M.#>4<& > %@0-R ?&%[_T"0P X-Y1P8!X 2! W(!\87O^\)# #@WE'!@ + M'@ X$#<@'QA>_Z@D, .#>4<& > "@0-R ?&%[_E"0P X-Y1P @!B ( + M A0 " ,< @#; ( LP " .L ( 0 . #DC + M6\;3 ! " @ * ! $ ! !@! $" !@ . /@ + M !H R #4 ( 4 " & ! 0 * $ /P ! %" , $F/>@! " + M0@0 @( P< 0 *P 0 BP ! /0$ (" + M +4 $ ! $ 'L 0 #A! " @ + M "G0 ! 4 ! !G $ RP0 @( + M FP 0 % 0 4P ! +4$ (" (\ + M $ T $ $8 0 "A! " @ ""0 ! + M A ! E $ >@0 @( =< 0 (P + M 0 @ ! %$$ (" &= $ ( $ + M 0 !(! " @ !:P ! % " 9 $ + M/ 0 @( 3H 0 !0 @ % ! # $ (" + M $' $ 4 ( \ 0 D! " @ + M T ! % " * $ & 0 @( + M )T 0 !0 @ !0 ! P$ (" !K + M $ 4 ( 0 &P #<+R]J96QL:6]T="]L;V-A;%]U + M !( !@ 0 'P 2 8 $ " $@ & ! + MA !( !@ 0 (@ 2 8 $ ", $@ & ! D "0 !@ 0 )0 B + M 8 $ "8 (P & ! O@ !( !@ 0 ,( 6 8 $ #& ' & ! + MR@ !X !@ 0 ,X @ 8 N9FEL90 "+__@ 9P%PC + | + | Sun3 assembly code. + | + + | + | Copyright 1989 Digital Equipment Corporation + | All Rights Reserved + | + | Permission to use, copy, and modify this software and its documentation is + | hereby granted only under the following terms and conditions. Both the + | above copyright notice and this permission notice must appear in all copies + | of the software, derivative works or modified versions, and any portions + | thereof, and both notices must appear in supporting documentation. + | + | Users of this software agree to the terms and conditions set forth herein, + | and hereby grant back to Digital a non-exclusive, unrestricted, royalty-free + | right and license under any changes, enhancements or extensions made to the + | core functions of the software, including but not limited to those affording + | compatibility with other hardware or software environments, but excluding + | applications which incorporate this software. Users further agree to use + | their best efforts to return to Digital any such changes, enhancements or + | extensions that they make and inform Digital of noteworthy uses of this + | software. Correspondence should be provided to Digital at: + | + | Director of Licensing + | Western Research Laboratory + | Digital Equipment Corporation + | 100 Hamilton Avenue + | Palo Alto, California 94301 + | + | This software may be distributed (but not offered for sale or transferred + | for compensation) to third parties, provided such third parties agree to + | abide by the terms and conditions of this notice. + | + | THE SOFTWARE IS PROVIDED "AS IS" AND DIGITAL EQUIPMENT CORP. DISCLAIMS ALL + | WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF + | MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL DIGITAL EQUIPMENT + | CORPORATION BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL + | DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR + | PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS + | ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS + | SOFTWARE. + | + + | + | sc_a2to5d2to7 + | + | sc_a2to5d2to7( a ) + | will return the contents of A2, ..., A5, D2, ..., D7 starting at address 'a'. + | + | + .text + .globl _sc_a2to5d2to7 + .even + _sc_a2to5d2to7: + movl sp@(4),a0 + movl a2,a0@(0) + movl a3,a0@(4) + movl a4,a0@(8) + movl a5,a0@(12) + movl d2,a0@(16) + movl d3,a0@(20) + movl d4,a0@(24) + movl d5,a0@(28) + movl d6,a0@(32) + movl d7,a0@(36) + rts