From: d90-awe@nada.kth.se
Newsgroups: comp.lang.dylan
Subject: Patches for Thomas to run under SunOS 4.1
Date: 21 Jan 93 18:20:02 GMT

Here follows the patches I've used to compile Thomas-1.1 under SunOS
4.1.2. It's basically the MCC02 patches from gatekeeper.dec.com
applied to the scc-files that thomas uses plus some small manual
changes.

They are also ftp-able from ftp.stacken.kth.se:pub/thomas.

*** 1.1	1993/01/14 22:52:13
--- callcc.c	1993/01/20 00:44:30
***************
*** 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
***************
*** 68,73 ****
--- 80,101 ----
  
  extern  TSCP  dynwind_new_2dcall_2fcc();
  
+ #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
+ 
+ #ifdef HP700
+ /*
+ #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
***************
*** 100,108 ****
--- 128,141 ----
  #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 );
  }
  
+ 
  /* Use the call-with-current-continuation provided by dynamic-wind.  Make the
     old call-with-current-continuation available for use from dynamic-wind.
  */
***************
*** 127,133 ****
--- 160,170 ----
  	   fp = sc_stackbase;
  	else
  	   fp = (T_U(sc_clink))->continuation.address;
+ #ifdef hp9000s800
+         count = ((unsigned)(STACKPTR)-(unsigned)(fp))/4;
+ #else
  	count = ((unsigned)(fp)-(unsigned)(STACKPTR))/4;
+ #endif
  	save_fp = fp;
  	save_count = count;
  	cp = sc_allocateheap( NULLCONTINUATIONSIZE+count+2+sc_maxdisplay,
***************
*** 143,149 ****
--- 180,190 ----
  	tp = &cp->continuation.word0;
  	rcount = sc_maxdisplay;
  	while  (rcount--)  *tp++ = (int)sc_display[ rcount ];
+ #ifdef hp9000s800
+        while  (count--)  *tp++ = *tos--;
+ #else
  	while  (count--)  *tp++ = *tos++;
+ #endif
  	MUTEXOFF;
  	if  (setjmp( cp->continuation.savedstate ) == 0)  {
  	   callccresult = sc_apply_2dtwo( function,
***************
*** 162,171 ****
--- 203,283 ----
  	      fp = &(T_U(sc_clink))->continuation.word0+sc_maxdisplay;
  	      count = (T_U(sc_clink))->continuation.length-sc_maxdisplay-
  	      				NULLCONTINUATIONSIZE;
+ #ifdef hp9000s800
+               while  (count--)  *tp-- = *fp++;
+ #else
  	      while  (count--)  *tp++ = *fp++;
+ #endif
  	      sc_clink = (T_U(sc_clink))->continuation.continuation;
  	   }
  	}
+ 	tp = &T_U( callcccp )->continuation.word0;
+ 	rcount = sc_maxdisplay;
+ 	while  (rcount--)  sc_display[ rcount ] = (TSCP)(*tp++);
+ 	sc_clink = T_U( callcccp )->continuation.continuation;
+ 	sc_stacktrace = T_U( callcccp )->continuation.stacktrace;
+ 	/* Move result onto the stack under mutex */
+ 	function = callccresult;
+ 	MUTEXOFF;
+ 	return( function );
+ }
+ 
+ 
+ 
+ static  catchthrown( result, cp )
+ 	TSCP  result, cp;
+ {
+         TSCP  clink;		/* link follower */
+ 	MUTEXON;
+ 	clink = sc_clink;
+ 	callccresult = result;
+ 	callcccp = cp;
+ 	/* Unwind CLINK to see if this continuation is currently on the
+ 	   stack.  */
+ 	while (clink != EMPTYLIST)  {
+ 	   if  (clink == cp) {
+ 	       sc_clink = clink;
+ 	       longjmp( (T_U(cp))->continuation.savedstate, 1 );
+ 	   }
+ 	   clink = (T_U(clink))->continuation.continuation;
+ 	}
+ 	/* Continuation is not currently on the stack, so user has
+ 	   tried to throw to non-existant catch. Error! */
+ 	sc_error( "CATCH/THROW", "Throw target is not on the stack",0);
+ }
+ 
+ 
+ TSCP  sc_catch_v;
+ 
+ TSCP  sc_catch( function )
+ 	TSCP  function;
+ {
+ 	SCP  cp;		/* Pointer to the continuation */
+ 
+ 	MUTEXON;
+ 	cp = sc_allocateheap( NULLCONTINUATIONSIZE+2+sc_maxdisplay,
+ 			      CONTINUATIONTAG,
+ 		              NULLCONTINUATIONSIZE+sc_maxdisplay );
+ 	cp->continuation.continuation = sc_clink;
+ 	cp->continuation.stacktrace = sc_stacktrace;
+ 	sc_clink = U_TX( cp );
+ 	cp->continuation.address =  STACKPTR;
+ 
+ 	tp = &cp->continuation.word0;
+ 	rcount = sc_maxdisplay;
+ 	while  (rcount--)  *tp++ = (int)sc_display[ rcount ];
+ 	MUTEXOFF;
+ 	if  (setjmp( cp->continuation.savedstate ) == 0)  {
+ 	   callccresult = sc_apply_2dtwo( function,
+ 	   			    sc_cons( sc_makeprocedure( 1, 0,
+ 							      catchthrown,
+ 						              U_TX( cp ) ),
+ 					     EMPTYLIST ) );
+ 	   sc_clink = T_U( sc_clink )->continuation.continuation;
+ 	   return( callccresult );
+ 	}
+ 
+ 	/* Return here when the catch is thrown to (continuation is invoked). */
  	tp = &T_U( callcccp )->continuation.word0;
  	rcount = sc_maxdisplay;
  	while  (rcount--)  sc_display[ rcount ] = (TSCP)(*tp++);
*** 1.1	1993/01/14 22:52:13
--- heap.c	1993/01/20 00:44:31
***************
*** 56,61 ****
--- 56,67 ----
  #ifdef VAX
  extern  sc_r2tor11();
  #endif
+ #ifdef APOLLO
+ extern sc_regs();
+ #endif
+ #if defined(SUN3) || defined(NeXT) || defined(HP300)
+ extern	sc_a2to5d2to7();
+ #endif
  
  /* Forward declarations */
  
***************
*** 100,108 ****
--- 106,116 ----
  
  int	sc_gcinfo;		/* controls logging */
  
+ #if !defined(SYSV) && !defined(hpux)
  static struct rusage gcru,	/* resource consumption during collection */
  	             startru,
  	      	     stopru;
+ #endif /* !defined(SYSV) && !defined(hpux) */
  
  static int  sc_newlist;		/* list of newly allocated pages */
  
***************
*** 158,163 ****
--- 166,172 ----
  	   if  (tail == page)  tail = 0;  \
  	}
  
+ #if !defined(SYSV) && !defined(hpux)
  /* The following function converts a rusage structure into an 18 word Scheme
     vector composed of the same items.
  */
***************
*** 288,293 ****
--- 297,309 ----
  	return( rusagevector( &gcru ) );
  }
  
+ #else
+ 
+ #define	getrusage(x,y)	/* no operation */
+ #define updategcru()	/* no operation */
+ 
+ #endif	/* !defined(SYSV) && !defined(hpux) */
+ 
  /* 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
***************
*** 396,402 ****
  	pp = STACKPTR;
  	while  (pp != sc_stackbase)  move_continuation_ptr( *pp++ );
  }
! #endif
  
  #ifdef VAX
  /* The following code is used to read the stack pointer.  The register
--- 412,418 ----
  	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
***************
*** 422,428 ****
  	pp = STACKPTR;
  	while  (pp != sc_stackbase)  move_continuation_ptr( *pp++ );
  }
! #endif
  
  #ifdef MIPS
  /* The following code is used to read the stack pointer.  The register
--- 438,444 ----
  	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
***************
*** 448,455 ****
  	pp = STACKPTR;
  	while  (pp != sc_stackbase)  move_continuation_ptr( *pp++ );
  }
! #endif
  
  
  /* The size of an extended object in words is returned by the following
     function.
--- 464,631 ----
  	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( &reg );
! }
! 
! /* 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;
! 	sc_jmp_buf tmp;
! 
! 	pp = STACKPTR;
! 	while  (pp != sc_stackbase)  move_continuation_ptr( *pp++ );
! }
! #endif SPARC
! 
! #if defined(SUN3) || defined(NeXT) || defined(HP300)
! /* 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( &reg+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 || NeXT || HP300 */
! 
! 
! #if defined(HP700)
! /* 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( &reg );
! }
! 
! /* All processor registers which might contain pointers are traced by the
!    following procedure.
! */
! 
! static  trace_stack_and_registers()
! {
!         int  i, r1tor18[18], *pp;
! 
!         sc_r1tor18( r1tor18 );
!         pp = STACKPTR;
!         while  (pp != sc_stackbase)  move_continuation_ptr( *pp-- );
! }
! #endif /* HP700 */
! 
! #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( &reg );
! }
! 
! /* All processor registers which might contain pointers are traced by the
!    following procedure.
! */
! 
! static  trace_stack_and_registers()
! {
! 	int  i, *pp;
! 	sc_jmp_buf tmp;
! 
! 	setjmp(tmp);
! 	pp = STACKPTR;
! 	while  (pp != sc_stackbase)  move_continuation_ptr( *pp++ );
! }
! #endif I386
! 
! #if defined(RS6000)
! /* 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( &reg );
! }
! 
! /* All processor registers which might contain pointers are traced by the
!    following procedure.
! */
  
+ static  trace_stack_and_registers()
+ {
+ 	int  i, *pp;
+ 
+ 	pp = STACKPTR;
+ 	while  (pp != sc_stackbase)  move_continuation_ptr( *pp++ );
+ }
+ #endif /* RS6000 */
  
  /* The size of an extended object in words is returned by the following
     function.
***************
*** 490,495 ****
--- 666,674 ----
  	   case  WORDALIGNTAG:
  	      return( WORDALIGNSIZE );
  
+ 	   case  OPAQUETAG:
+ 	      return( OPAQUESIZE );
+ 
  	   default:
  	      fprintf( stderr,
  	      	       "***** COLLECT Unknown extended object: %x %x\n",
***************
*** 595,601 ****
  		}
  		words = extendedsize( pp );
  		length = words;
! 		newp = (int*)sc_allocateheap( extendedsize( pp ),
  					      pp->extendedobj.tag, 0 );
  		new = U_T( newp, EXTENDEDTAG );
  		oldp = (int*)pp;
--- 774,780 ----
  		}
  		words = extendedsize( pp );
  		length = words;
! 		newp = (int*)sc_allocateheap( length,
  					      pp->extendedobj.tag, 0 );
  		new = U_T( newp, EXTENDEDTAG );
  		oldp = (int*)pp;
***************
*** 699,704 ****
--- 878,889 ----
  		 size = WORDALIGNSIZE;
  		 break;
  
+ 	      case  OPAQUETAG:
+ 	   	 move_ptr( pp->opaque.type );
+ 		 move_ptr( pp->opaque.body );
+ 		 size = OPAQUESIZE;
+ 		 break;
+ 
  	      default:
  	         pointererror( "%x is not a valid extended object tag\n",
  	         	       pp->extendedobj.tag );
***************
*** 1000,1005 ****
--- 1185,1196 ----
  		 size = WORDALIGNSIZE;
  		 break;
  
+ 	      case  OPAQUETAG:
+ 		 pp->opaque.type = correct( pp->opaque.type );
+ 		 pp->opaque.body = correct( pp->opaque.body );
+ 		 size = OPAQUESIZE;
+ 		 break;
+ 
  	      default:
  	         fprintf( stderr,
  	      	          "***** COLLECT Unknown extended object: %x %x\n",
***************
*** 1303,1308 ****
--- 1494,1505 ----
  		 size = WORDALIGNSIZE;
  		 break;
  
+ 	      case  OPAQUETAG:
+ 		 check_ptr( pp->opaque.type );
+ 		 check_ptr( pp->opaque.body );
+ 		 size = OPAQUESIZE;
+ 		 break;
+ 
  	      default:
  	         pointererror( "%x is not a valid extended object tag\n",
  	         	       pp->extendedobj.tag );
***************
*** 1407,1413 ****
--- 1604,1612 ----
  		    (sc_extwaste*100)/(sc_heappages*PAGEWORDS),
  		    (sc_heappages*PAGEBYTES+ONEMB/2)/ONEMB );
  	}
+ #if !defined(SYSV) && !defined(hpux)
  	getrusage( 0, &startru );
+ #endif /* !defined(SYSV) && !defined(hpux) */
  
  	/* Zero the current cons block, end the current extended block,
  	   initialize sc_locklist, advance the generation.
***************
*** 1499,1507 ****
--- 1698,1709 ----
  	sc_allocatedheappages = sc_generationpages;
  
  	/* Finish up */
+ #if !defined(SYSV) && !defined(hpux)
  	getrusage( 0, &stopru );
  	updategcru();
+ #endif /* !defined(SYSV) && !defined(hpux) */
  	if  (sc_gcinfo)  { 
+ #if !defined(SYSV) && !defined(hpux)
  	   fprintf( stderr,
  	            "              %d%% locked  %d%% retained  %d user ms",
  		    (sc_lockcnt*100)/sc_heappages,
***************
*** 1511,1516 ****
--- 1713,1724 ----
  	   	    "  %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 /* !defined(SYSV) && !defined(hpux) */
  	}
  	if  (sc_gcinfo == 2)  {
  	   /* Perform additional consistency checks */
***************
*** 1741,1748 ****
--- 1949,1960 ----
     the Scheme object with that value.
  */
  
+ #ifdef PRISM
+ TSCP sc_makefloat32( float value )
+ #else
  TSCP sc_makefloat32( value )
  	float  value;
+ #endif
  {
  	SCP  pp;
  
***************
*** 1751,1757 ****
  	   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 );
--- 1963,1970 ----
  	   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 );
***************
*** 1763,1772 ****
--- 1976,1995 ----
  /* 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;
  
***************
*** 1776,1782 ****
  	   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 );
--- 1999,2006 ----
  	   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 );
*** 1.1	1993/01/14 22:52:13
--- heap.h	1993/01/20 00:44:31
***************
*** 42,51 ****
--- 42,78 ----
  /* Import definitions */
  
  #ifndef rusage
+ 
+ #ifdef apollo
+ #include <sys/time.h>
+ #else
+ #ifdef SPARC
+ #include <sys/time.h>
+ #else
+ #ifdef SUN3
+ #include <sys/time.h>
+ #else
+ #ifdef NeXT
+ #include <sys/time.h>
+ #else
+ #ifdef HP700
+ #include <sys/time.h>
+ #else
+ #ifndef SYSV
  #include <time.h>
+ #endif
+ #endif
+ #endif
+ #endif
+ #endif
+ #endif
+ 
+ #ifndef SYSV
  #include <sys/resource.h>
  #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
***************
*** 333,338 ****
--- 360,402 ----
  
  #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
+ 
+ #ifdef HP300
+ #define STACKPTR sc_processor_register( 15 )
+ #endif
+ 
+ #ifdef HP700
+ #define STACKPTR sc_processor_register( 30 )
+ #endif
+ 
+ #ifdef NeXT
+ #define STACKPTR sc_processor_register( 15 )
+ #endif
+ 
+ #ifdef RS6000
+ #define STACKPTR sc_processor_register( 1 )
  #endif
  
  /* Some objects require cleanup actions when they are freed.  For example,
*** 1.1	1993/01/14 22:52:13
--- scinit.c	1993/01/20 00:44:31
***************
*** 47,61 ****
  
  /* External Definitions */
  
  extern  char *sbrk();
  extern  char *getenv();
  
  extern  errno;			/* C-library Error flag */
  
- #include <sys/file.h>
  #include <sys/types.h>
  #include <sys/uio.h>
  #include <strings.h>
  #include <varargs.h>
  
  /* Definitions for objects within sc */
--- 47,68 ----
  
  /* External Definitions */
  
+ #ifdef NeXT
+ #define sbrk my_sbrk
+ #endif
  extern  char *sbrk();
  extern  char *getenv();
  
  extern  errno;			/* C-library Error flag */
  
  #include <sys/types.h>
+ #include <sys/file.h>
  #include <sys/uio.h>
+ #if !defined(SYSV) && !defined(HP300)
  #include <strings.h>
+ #else
+ #include <string.h>
+ #endif /* !defined(SYSV) && !defined(HP300) */
  #include <varargs.h>
  
  /* Definitions for objects within sc */
***************
*** 75,106 ****
  extern  etext;
  #ifdef MIPS
  #define ETEXT	((int)&etext)	/* First address after text */
  #ifdef BIGMIPS
  #include <sys/param.h>
  #include <sys/immu.h> */
  #define STACKBASE (int*)USERSTACK
  #else
  #include <mips/param.h>
  #include <mips/vmparam.h>
  #define STACKBASE (int*)USRSTACK
! #endif
! #endif
  #ifdef TITAN
  #define ETEXT	etext		/* First address after text */
  #include <sys/mparam.h>
  #define STACKBASE (int*)(MAXUSERADDR+1)
  #endif
  #ifdef VAX
  #define ETEXT	((int)&etext)	/* First address after text */
  #include <vax/param.h>
  #include <vax/vmparam.h>
  #define STACKBASE (int*)USRSTACK
  #endif
  
  /* 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,
--- 82,248 ----
  extern  etext;
  #ifdef MIPS
  #define ETEXT	((int)&etext)	/* First address after text */
+ #ifndef sony_news
  #ifdef BIGMIPS
  #include <sys/param.h>
  #include <sys/immu.h> */
+ #define MACH_STRING "Big Endian MIPS"
+ #define CPU_STRING "R2000/R3000"
+ #define OS_STRING "RISCOS"
  #define STACKBASE (int*)USERSTACK
  #else
  #include <mips/param.h>
  #include <mips/vmparam.h>
+ #define MACH_STRING "DECstation"
+ #define CPU_STRING "R2000/R3000"
+ #define OS_STRING "ULTRIX"
  #define STACKBASE (int*)USRSTACK
! #endif /* BIGMIPS */
! #else
! #include <sys/param.h>
! #include <sys/vmparam.h>
! #define MACH_STRING "Sony News3200"
! #define CPU_STRING "R3000"
! #define OS_STRING "NewsOS"
! #define STACKBASE (int*)USRSTACK
! #endif /* sony_news */
! #endif /* MIPS */
! 
  #ifdef TITAN
  #define ETEXT	etext		/* First address after text */
  #include <sys/mparam.h>
  #define STACKBASE (int*)(MAXUSERADDR+1)
  #endif
+ 
  #ifdef VAX
  #define ETEXT	((int)&etext)	/* First address after text */
  #include <vax/param.h>
  #include <vax/vmparam.h>
  #define STACKBASE (int*)USRSTACK
+ #define MACH_STRING "VAX"
+ #define CPU_STRING "VAX"
+ #define OS_STRING "ULTRIX"
+ #endif
+ 
+ #ifdef apollo
+ #  ifdef _ISP_A88K
+ #    define PRISM 1
+ #  else
+ #    define APOLLO 1
+ #  endif
+ #define ETEXT	((int)&etext)	/* First address after text */
+ #include <sys/param.h>
+ /* the stack back moves depending on shared libraries */
+ #include <apollo/base.h>
+ #include <apollo/error.h>
+ #include <apollo/proc2.h>
+ static proc2_$info_t sc_apollo_proc2;
+ #define STACKBASE ((int*) sc_apollo_proc2.stack_base)
+ #ifdef APOLLO
+ #define MACH_STRING "Apollo"
+ #define CPU_STRING "68K"
+ #define OS_STRING "Domain/OS"
+ #else
+ #define MACH_STRING "Apollo"
+ #define CPU_STRING "PRISM"
+ #define OS_STRING "Domain/OS"
+ #endif
+ #endif
+ 
+ #ifdef SPARC
+ #define ETEXT	((int)&etext)	/* First address after text */
+ #include <sun4/vmparam.h>
+ #define STACKBASE (int*)USRSTACK
+ #define CPU_STRING "SPARC"
+ #ifdef sun
+ #define MACH_STRING "Sun4/SparcStation"
+ #define OS_STRING "SunOS"
+ #else
+ #define MACH_STRING "SparcClone"
+ #define OS_STRING "SparcOS"
+ #endif
+ #endif
+ 
+ #ifdef SUN3
+ #define ETEXT	((int)&etext)	/* First address after text */
+ #include <sun3/param.h>
+ #include <sun3/vmparam.h>
+ #define STACKBASE (int*)USRSTACK
+ #define MACH_STRING "Sun3"
+ #define CPU_STRING "68K"
+ #define OS_STRING "SunOS"
+ #endif
+ 
+ #if defined(HP300) || defined(HP700)
+ #define ETEXT	((int)&etext)	/* First address after text */
+ #include <sys/param.h>
+ #include <sys/vmparam.h>
+ #if defined(HP700)
+ #include <sys/user.h>
+ #if defined(sc_error)
+ #undef sc_error
+ #endif
+ #define START_DATA_SECTION 0x40000000
+ #endif
+ #define STACKBASE (int*)USRSTACK
+ #if defined(HP300)
+ #define MACH_STRING "HP9000s300"
+ #define CPU_STRING "68K"
+ #else
+ #define MACH_STRING "HP9000s700"
+ #define CPU_STRING "PARISC"
+ #endif /* defined(HP300) */
+ #define OS_STRING "HPUX"
+ #endif /* defined(HP300) || defined(HP700) */
+ 
+ #ifdef NeXT
+ #define ETEXT	((int)get_etext())
+ #include <next/vmparam.h>
+ #define STACKBASE (int*)USRSTACK
+ #define MACH_STRING "NeXT"
+ #define CPU_STRING "68K"
+ #define OS_STRING "NeXT OS"
+ #endif
+ 
+ #ifdef ISC386IX
+ #if I386SHLIB
+ int *sc__etext;
+ #define ETEXT ((int)sc__etext) /* first address after text */
+ #else
+ #define ETEXT	((int)&etext)	/* First address after text */
+ #endif
+ #include <sys/types.h>
+ #include <sys/fcntl.h>		/* probably should be elsewhere */
+ #include <sys/immu.h>
+ #define STACKBASE (int*)UVSTACK
+ #define MACH_STRING "AT/386"
+ #define CPU_STRING "Intel 386"
+ #define OS_STRING "System V.3.2"
+ #endif
+ /* ditto for SCO */
+ 
+ #if defined(_AIX)
+ extern char *_etext;
+ #define ETEXT ((int)&_etext)
+ #if defined(_IBMR2)
+ #include <sys/pseg.h>
+ #define STACKBASE (int *)USRSTACK
+ #define MACH_STRING "IBM RS/6000"
+ #define CPU_STRING "RS6000"
+ #else
+ #define MACH_STRING "IBM RT"
+ #define CPU_STRING "RT"
  #endif
+ #define OS_STRING "Aix"
+ #endif /* _AIX */
  
  /* Global data structure for this module. */
  
! /* this struct must look like an SCOBJ */
! static struct
! {
!     UNSIGNED_FIELDS2( tag:8,  length:24);
! } emptyvector, emptystring[2];
  
  FILE   *sc_stdin,	/* Standard I/O Subroutine FILE pointers */
         *sc_stdout,
***************
*** 200,208 ****
--- 342,353 ----
  DEFSTRING( t1060, "AFTER-COLLECT", 13 );
  DEFSTRING( t1062, "*FROZEN-OBJECTS*", 16 );
  DEFSTRING( t2003, "*INITIAL-HEAP-FILE*", 19 );
+ DEFSTRING( t1061, "CATCH", 5 );
+ DEFSTRING( t1063, "MAKE-OPAQUE-OBJECT", 18 );
  
  static  init_procs()
  {
+ #if !defined(SYSV) && !defined(hpux)
          INITIALIZEVAR( U_TX( ADR( t1030 ) ), 
                         ADR( sc_my_2drusage_v ), 
                         MAKEPROCEDURE( 0, 
***************
*** 212,217 ****
--- 357,363 ----
                         MAKEPROCEDURE( 0, 
                                        0, 
                                        sc_collect_2drusage, EMPTYLIST ) );
+ #endif /* !defined(SYSV) && !defined(hpux) */
          INITIALIZEVAR( U_TX( ADR( t1034 ) ), 
                         ADR( sc_collect_v ), 
                         MAKEPROCEDURE( 0, 
***************
*** 281,286 ****
--- 427,441 ----
          INITIALIZEVAR( U_TX( ADR( t2003 ) ),
                         ADR( sc__2dfile_2a_67475874_v ),
                         FALSEVALUE );
+ 	INITIALIZEVAR( U_TX( ADR( t1061 ) ),
+ 		       ADR( sc_catch_v ),
+ 		       MAKEPROCEDURE( 1,
+ 				      0, sc_catch, EMPTYLIST ) );
+ 	INITIALIZEVAR( U_TX( ADR( t1063 ) ),
+ 		       ADR( sc_make_2dopaque_2dobject_v ),
+ 		       MAKEPROCEDURE( 2,
+ 				      0, sc_make_2dopaque_2dobject,
+ 				      EMPTYLIST ) );
          MAXDISPLAY( 0 );
          return;
  }
***************
*** 292,303 ****
--- 447,468 ----
     boundaries and counts are rounded up to full pages.
  */
  
+ #if !defined(HP700)
  static char  *getmem( bytes )
  	int  bytes;
+ #else
+ static char  *getmem( bytes, first )
+ 	int  bytes;
+         int  first;
+ #endif
  {
  	char  *memp;
  
  	memp = sbrk( 0 );
+ #ifdef HP700  /* move base pointer into data section */
+        if ((int *)memp - first < START_DATA_SECTION)
+          memp= sbrk( (char *)START_DATA_SECTION - (char *)((int *)memp - first));
+ #endif
  	if  ((int)memp & (PAGEBYTES-1))
  	   sbrk( PAGEBYTES-(int)memp & (PAGEBYTES-1) );
  	bytes = (bytes+PAGEBYTES-1) & ~(PAGEBYTES-1);
***************
*** 336,342 ****
--- 501,511 ----
  	char*  addr;
  
  	bytes = ((last-first+1)*sizeof( int )*4+PAGEBYTES-1) & ~(PAGEBYTES-1);
+ #ifndef HP700
  	addr = getmem( bytes );
+ #else
+         addr = getmem( bytes , first);
+ #endif
  	if  (addr == NULL)  {
  	   *pagegen = *type = *lock = *link = NULL;
  	   return;
***************
*** 357,367 ****
--- 526,553 ----
  	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
+ 
  	sc_limit = sclimit;
  	sc_heappages = scheap*(ONEMB/PAGEBYTES);
  	sc_maxheappages = scmaxheap*(ONEMB/PAGEBYTES);
  	sc_allocatedheappages = 0;
+ #ifndef HP700
  	freebase = getmem( scheap*ONEMB );
+ #else
+ 	freebase = getmem( scheap*ONEMB, 0);
+ #endif
  	sc_firstheappage = ADDRESS_PAGE( freebase );
  	sc_lastheappage = sc_firstheappage+sc_heappages-1;
  	sc_freepage = sc_firstheappage;
***************
*** 383,388 ****
--- 569,576 ----
  	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;
***************
*** 412,421 ****
  	   sc_globals = addtoSCPTRS( sc_globals, &sc_unknownproc[ i ] );
  	}
  	module_initialized = 1;
! 	if  (sc_gcinfo)
  	   fprintf( stderr,
  	    "***** SCGCINFO = %d  SCHEAP = %d  SCMAXHEAP = %d  SCLIMIT = %d\n",
  	   	    sc_gcinfo, scheap, scmaxheap, sclimit );
  	/* Initialize dynwind as it has redefined call/cc */
  	dynwind__init();
  }
--- 600,615 ----
  	   sc_globals = addtoSCPTRS( sc_globals, &sc_unknownproc[ i ] );
  	}
  	module_initialized = 1;
! 	if  (sc_gcinfo) {
! #ifdef sun
! 	    /* in SunOS, stderr is line buffered, which causes some unwanted */
! 	    /* malloc..  */
! 	    setbuf(stderr, (char*)0);
! #endif /* sun */
  	   fprintf( stderr,
  	    "***** SCGCINFO = %d  SCHEAP = %d  SCMAXHEAP = %d  SCLIMIT = %d\n",
  	   	    sc_gcinfo, scheap, scmaxheap, sclimit );
+        }
  	/* Initialize dynwind as it has redefined call/cc */
  	dynwind__init();
  }
***************
*** 450,456 ****
  	      fprintf( stderr, "***** To heap %x %x\n", addr, addr+count-1 );
  	   for  (i = first_addr; i <= last_addr; i++)  {
  	      if  (sc_pagegeneration[ i ])  {
! 	         fprintf( "***** COLLECT Trying to reallocate page %d\n", i );
  		 abort();
  	      }
  	      sc_pagegeneration[ i ] = 1;
--- 644,651 ----
  	      fprintf( stderr, "***** To heap %x %x\n", addr, addr+count-1 );
  	   for  (i = first_addr; i <= last_addr; i++)  {
  	      if  (sc_pagegeneration[ i ])  {
! 	         fprintf( stderr,
! 			  "***** COLLECT Trying to reallocate page %d\n", i );
  		 abort();
  	      }
  	      sc_pagegeneration[ i ] = 1;
***************
*** 535,541 ****
--- 730,740 ----
  	   add_pages = (sc_maxheappages*25)/100;
  	if  (sc_gcinfo)
  	   fprintf( stderr, "%sheap expanded to ", msgheader );
+ #ifndef HP700
  	addrtoheap( getmem( add_pages*PAGEBYTES ), add_pages*PAGEBYTES );
+ #else
+ 	addrtoheap( getmem( add_pages*PAGEBYTES, 0 ), add_pages*PAGEBYTES );
+ #endif
  	if  (sc_gcinfo)
  	   fprintf( stderr, "%d MB\n",
  		    (sc_heappages*PAGEBYTES+ONEMB/2)/ONEMB );
***************
*** 753,759 ****
--- 952,962 ----
  	if  (scmaxheap < scheap)  scmaxheap = scheap;
  	sc_maxheappages = scmaxheap*(ONEMB/PAGEBYTES);
  	sc_allocatedheappages = save.allocatedheappages;
+ #ifndef HP700
  	freebase = getmem( scheap*ONEMB );
+ #else
+ 	freebase = getmem( scheap*ONEMB, 0 );
+ #endif
  	sc_firstheappage = ADDRESS_PAGE( freebase );
  	sc_lastheappage = sc_firstheappage+sc_heappages-1;
  	sc_firstheapp = (int*)freebase;
***************
*** 789,794 ****
--- 992,999 ----
  	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;
***************
*** 878,883 ****
--- 1083,1089 ----
  	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
***************
*** 895,927 ****
  	   sc_cons(
  	      sc_cstringtostring( "Scheme->C" ),
  	      sc_cons(
! 	         sc_cstringtostring( "01nov91jfb+wcdw" ),
  	         sc_cons(
! #ifdef MIPS
! #ifdef BIGENDIAN
! 		    sc_cstringtostring( "Big Endian MIPS" ),
! #else
! 		    sc_cstringtostring( "DECstation" ),
! #endif
! #endif
! #ifdef TITAN
! 		    sc_cstringtostring( "WRL-TITAN" ),
! #endif
! #ifdef VAX
! 		    sc_cstringtostring( "VAX" ),
! #endif
  		    sc_cons(
! #ifdef MIPS
! 		       sc_cstringtostring( "R2000/R3000" ),
! #endif
! #ifdef TITAN
! 		       sc_cstringtostring( "BYTE-ADDRESSED" ),
! #endif
! #ifdef VAX
! 		       sc_cstringtostring( "VAX" ),
! #endif
  		       sc_cons(
! 		          sc_cstringtostring( "ULTRIX" ),
  		          sc_cons(
  			      FALSEVALUE,
  			      EMPTYLIST
--- 1101,1113 ----
  	   sc_cons(
  	      sc_cstringtostring( "Scheme->C" ),
  	      sc_cons(
! 	         sc_cstringtostring( "01nov91jfb+wcdw+MCC02" ),
  	         sc_cons(
! 		    sc_cstringtostring( MACH_STRING ),
  		    sc_cons(
! 		       sc_cstringtostring( CPU_STRING ),
  		       sc_cons(
! 		          sc_cstringtostring( OS_STRING ),
  		          sc_cons(
  			      FALSEVALUE,
  			      EMPTYLIST
***************
*** 933,935 ****
--- 1119,1166 ----
  	          )
  	      );
  }
+ 
+ #ifdef NeXT
+ #include <mach.h>
+ #include <stdio.h>
+ 
+ char               *my_current_brk = 0;
+ char               *my_end_brk = 0;
+ 
+ char *
+ my_sbrk(int incr)
+ {
+   char               *temp, *ptr;
+   kern_return_t       rtn;
+ 
+   if (my_current_brk == 0) {
+     if ((rtn = vm_allocate(task_self(), (vm_address_t *) & my_current_brk,
+ 			   vm_page_size, 1)) != KERN_SUCCESS) {
+       mach_error("my_sbrk: vm_allocate failed", rtn);
+       return ((char *)-1);
+     }
+     my_end_brk = my_current_brk + vm_page_size;
+   }
+   if (incr == 0) return (my_current_brk);
+  more:
+   ptr = my_current_brk + incr;
+   if (ptr <= my_end_brk) {
+     temp = my_current_brk;
+     my_current_brk = ptr;
+     return (temp);
+   } else {
+     if ((rtn = vm_allocate(task_self(), (vm_address_t *) &ptr,
+ 			   vm_page_size, 1)) != KERN_SUCCESS) {
+       mach_error("my_sbrk: vm_allocate failed", rtn);
+       return ((char *)-1);
+     }
+     if (ptr != my_end_brk) {
+       fprintf(stderr, "my_sbrk: internal error\n");
+       fflush(stderr);
+       return ((char *)-1);
+     }
+     my_end_brk = ptr + vm_page_size;
+     goto more;
+   }
+ }
+ #endif /* NeXT */

They work for me, at least. If you got any problems with them I can't
guarantee anything but if you mail me I could try to help you.

/assar
Newsgroups: comp.lang.dylan