home *** CD-ROM | disk | FTP | other *** search
/ The Fred Fish Collection 1.5 / ffcollection-1-5-1992-11.iso / ff_progs / prog_c / schem2c1.lzh / Scheme2C / Scheme-src.lzh / scrt / objects.c < prev    next >
Encoding:
C/C++ Source or Header  |  1991-10-11  |  18.4 KB  |  643 lines
  1. /* SCHEME->C */
  2.  
  3. /*              Copyright 1989 Digital Equipment Corporation
  4.  *                         All Rights Reserved
  5.  *
  6.  * Permission to use, copy, and modify this software and its documentation is
  7.  * hereby granted only under the following terms and conditions.  Both the
  8.  * above copyright notice and this permission notice must appear in all copies
  9.  * of the software, derivative works or modified versions, and any portions
  10.  * thereof, and both notices must appear in supporting documentation.
  11.  *
  12.  * Users of this software agree to the terms and conditions set forth herein,
  13.  * and hereby grant back to Digital a non-exclusive, unrestricted, royalty-free
  14.  * right and license under any changes, enhancements or extensions made to the
  15.  * core functions of the software, including but not limited to those affording
  16.  * compatibility with other hardware or software environments, but excluding
  17.  * applications which incorporate this software.  Users further agree to use
  18.  * their best efforts to return to Digital any such changes, enhancements or
  19.  * extensions that they make and inform Digital of noteworthy uses of this
  20.  * software.  Correspondence should be provided to Digital at:
  21.  * 
  22.  *                       Director of Licensing
  23.  *                       Western Research Laboratory
  24.  *                       Digital Equipment Corporation
  25.  *                       100 Hamilton Avenue
  26.  *                       Palo Alto, California  94301  
  27.  * 
  28.  * This software may be distributed (but not offered for sale or transferred
  29.  * for compensation) to third parties, provided such third parties agree to
  30.  * abide by the terms and conditions of this notice.  
  31.  * 
  32.  * THE SOFTWARE IS PROVIDED "AS IS" AND DIGITAL EQUIPMENT CORP. DISCLAIMS ALL
  33.  * WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF
  34.  * MERCHANTABILITY AND FITNESS.   IN NO EVENT SHALL DIGITAL EQUIPMENT
  35.  * CORPORATION BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL
  36.  * DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR
  37.  * PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS
  38.  * ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS
  39.  * SOFTWARE.
  40. */
  41.  
  42. /* This module implements the object storage allocation functions.  */
  43.  
  44. /* Imported definitions */
  45.  
  46. #include "objects.h"
  47. #include "scinit.h"
  48. #include "heap.h"
  49. #include "signal.h"
  50. #include "apply.h"
  51. #include "cio.h"
  52. #include <varargs.h>
  53.  
  54. extern  TSCP  scrt1_reverse();
  55.  
  56. /* Allocate storage for objects defined in objects.h  */
  57.  
  58. TSCP  sc_obarray;         /* OBARRAY for symbols */
  59.  
  60. struct SCPTRS  *sc_constants;    /* Table of compile time constant addresses */
  61.  
  62. struct SCPTRS  *sc_globals;    /* Table of top level variable addresses */
  63.  
  64. int  sc_maxdisplay = 0;      /* The DISPLAY */
  65.  
  66. TSCP  sc_display[ 200 ];
  67.  
  68. TSCP  sc_emptylist,    /* Immediate denoting empty list */
  69.       sc_emptystring,    /* Pointer to the empty string */
  70.       sc_emptyvector,    /* Pointer to the empty vector */
  71.       sc_falsevalue,    /* Immediate denoting false */
  72.       sc_truevalue,    /* Immediate denoting true  */
  73.       sc_eofobject,    /* Immediate denoting end-of-file */
  74.       sc_undefined;    /* Immediate denoting the undefined value */
  75.  
  76. struct STACKTRACE  *sc_stacktrace;  /* Pointer to debug stack trace records */
  77.  
  78. /* Entries are added to SCPTRS structures by the following procedure.  It is
  79.    called with a pointer to the structure and a value to add.  It returns the
  80.    pointer to the expanded structure.
  81. */
  82.  
  83. struct SCPTRS*  addtoSCPTRS( s, p )
  84.     struct SCPTRS*  s;
  85.     TSCP  *p;
  86. {
  87.     if  (s == NULL)  {
  88.        /* Initially allocate the table */
  89.        s = (struct SCPTRS*)malloc( sizeofSCPTRS( 500 ) );
  90.        s->count = 0;
  91.        s->limit = 500;
  92.     }  else  if  (s->count == s->limit)  {
  93.        s->limit = s->limit+100;
  94.        s = (struct SCPTRS*)realloc( s, sizeofSCPTRS( s->limit ) );
  95.     }
  96.     s->ptrs[ s->count++ ] = p;
  97.     return( s );
  98. }
  99.  
  100. /* Strings are allocated by the following function which takes a length (as a
  101.    tsfixed value), and a char initialization value.  It will return a Scheme
  102.    pointer to the new string.  The strings will be null terminated in order to
  103.    be compatible with C strings.  This function is visible as MAKE-STRING
  104.    inside Scheme.
  105. */
  106.  
  107. TSCP  sc_make_2dstring_v;
  108.  
  109. TSCP  sc_make_2dstring( length, initial )
  110.     TSCP  length, initial;
  111. {
  112.     int  len, x;
  113.     char  initchar, *cp;
  114.     SCP  sp;
  115.  
  116.     len = FIXED_C( length );
  117.     if  ((TSCPTAG( length ) != FIXNUMTAG) || len < 0)
  118.        sc_error( "MAKE-STRING", "Argument is not a POSITIVE INTEGER", 0 );
  119.     if  (len == 0)  return( sc_emptystring );
  120.     if  (initial != EMPTYLIST)  {
  121.        initial = T_U( initial )->pair.car;
  122.        if  (TSCPIMMEDIATETAG( initial ) != CHARACTERTAG)
  123.           sc_error( "MAKE-STRING", "Argument is not a CHARACTER", 0 );
  124.        initchar = CHAR_C( initial );
  125.     }
  126.     MUTEXON;
  127.     sp = sc_allocateheap( STRINGSIZE( len ), STRINGTAG, len );
  128.     cp = &sp->string.char0;
  129.     if  (initial != EMPTYLIST)  {
  130.        x = len;
  131.        while  (x--)  *cp++ = initchar;
  132.     }
  133.     else  cp = cp+len;
  134.     x = 4-(len & 3);        /* Null bytes in rest of last word */
  135.     while  (x--) *cp++ = 0;
  136.     MUTEXOFF;
  137.     return( U_T( sp, EXTENDEDTAG ) );
  138. }
  139.  
  140. /* A copy of a string is made by the following procedure.  It is available
  141.    inside Scheme as STRING-COPY.
  142. */
  143.  
  144. TSCP  sc_string_2dcopy_v;
  145.  
  146. TSCP  sc_string_2dcopy( string )
  147.     TSCP  string;
  148. {
  149.     SCP  ustring, newstring;
  150.     int  words, *from, *to;
  151.  
  152.     ustring = T_U( string );
  153.     if  ((TSCPTAG( string ) != EXTENDEDTAG) ||
  154.          ustring->string.tag != STRINGTAG)
  155.        sc_error( "STRING-COPY", "Argument is not a STRING", 0 );
  156.     if  (string == sc_emptystring)  return( string );
  157.     words = STRINGSIZE( ustring->string.length );
  158.     MUTEXON;
  159.     newstring = sc_allocateheap( words, 0, 0 );
  160.     from = (int*)ustring;
  161.     to = (int*)newstring;
  162.     while  (words--)  *to++ = *from++;
  163.     MUTEXOFF;
  164.     return( U_T( newstring, EXTENDEDTAG ) );
  165. }
  166.  
  167. /* C strings are converted to heap allocated Scheme strings by the following
  168.    function.
  169. */
  170.  
  171. TSCP  sc_cstringtostring( cstring )
  172.     char  *cstring;
  173. {
  174.     int  len, x;
  175.     char  *cp;
  176.     SCP  sp;
  177.  
  178.     len = 0;
  179.     cp = cstring;
  180.     if  (cp)  while  (*cp++)  len++;
  181.     if  (len == 0)  return( sc_emptystring );
  182.     MUTEXON;
  183.     sp = sc_allocateheap( STRINGSIZE( len ), STRINGTAG, len );    
  184.     cp = &sp->string.char0;
  185.     x = len;
  186.     while  (x--)  *cp++ = *cstring++;
  187.     x = 4-(len & 3);        /* Null bytes in rest of last word */
  188.     while  (x--) *cp++ = 0;
  189.     MUTEXOFF;
  190.     return( U_T( sp, EXTENDEDTAG ) );
  191. }
  192.  
  193. /* Vectors are allocated by the following functions which takes a length (as a
  194.    tsfixed value), and an initialization value.  It will return a Scheme
  195.    pointer to the new vector.  It has the name MAKE-VECTOR in Scheme.
  196. */
  197.  
  198. TSCP  sc_make_2dvector_v;
  199.  
  200. TSCP  sc_make_2dvector( length, initial )
  201.     TSCP  length, initial;
  202. {
  203.     int  len;
  204.     SCP  vp;
  205.     PATSCP  ve;
  206.  
  207.     len = FIXED_C( length );
  208.     if  ((TSCPTAG( length ) != FIXNUMTAG) || len < 0)
  209.        sc_error( "MAKE-VECTOR", "Argument is not a POSITIVE INTEGER", 0 );
  210.     if  (len == 0)  return( sc_emptyvector );
  211.     MUTEXON;
  212.     vp = sc_allocateheap( VECTORSIZE( len ), VECTORTAG, len );
  213.     ve = &vp->vector.element0;
  214.     if  (initial != EMPTYLIST)  initial = T_U( initial )->pair.car;
  215.     while  (len--)  *ve++ = initial;
  216.     MUTEXOFF;
  217.     return( U_T( vp, EXTENDEDTAG ) );
  218. }
  219.  
  220. /* Closures are constructed by the following function.  It takes a previous
  221.    closure pointer, a closure size, and the values to be closed.  It returns
  222.    a Scheme pointer to the closure.  It is used by compiled code to heap
  223.    allocate variables and is visible within the compiler as MAKECLOSURE.
  224. */
  225.  
  226. TSCP sc_makeclosure( va_alist )
  227.     va_dcl
  228. {
  229.     va_list  argl;
  230.     TSCP prevclosure;
  231.     int  count;
  232.     SCP  cp;
  233.     PATSCP  vars;
  234.  
  235.     MUTEXON;
  236.     va_start( argl );
  237.     prevclosure = va_arg( argl, TSCP );
  238.     count = va_arg( argl, int );
  239.     cp = sc_allocateheap( CLOSURESIZE( count ), CLOSURETAG, count );
  240.     cp->closure.closure = prevclosure;
  241.     vars = &cp->closure.var0;
  242.     while  (count--)  *vars++ = va_arg( argl, TSCP );
  243.     MUTEXOFF;
  244.     return( U_T( cp, EXTENDEDTAG ) );
  245. }
  246.  
  247. /* Procedure objects are constructed by the following function.  It takes the
  248.    required variable count, the optvars flag, the function, and the current
  249.    closure.  It returns a Scheme pointer to the procedure.  It is used by
  250.    compiled code to make the value of a (LAMBDA (...) ...) expression.  It is
  251.    visible within the compiler as MAKEPROCEDURE.
  252. */
  253.  
  254. TSCP sc_makeprocedure( reqvars, optvars, function, closure )
  255.     int  reqvars, optvars;
  256.     TSCP  closure;
  257.     TSCPP function;
  258. {
  259.     SCP  pp;
  260.  
  261.     if  (reqvars > MAXARGS)
  262.        sc_error( "MAKEPROCEDURE",
  263.                 "PROCEDURE requires too many arguments",
  264.                 0 );
  265.     if  (optvars)  reqvars = reqvars+256;
  266.     MUTEXON;
  267.     pp = sc_allocateheap( PROCEDURESIZE, PROCEDURETAG, reqvars );
  268.     pp->procedure.code = function;
  269.     pp->procedure.closure = closure;
  270.     MUTEXOFF;
  271.     return( U_T( pp, EXTENDEDTAG ) );
  272. }
  273.  
  274. /* Compiled global variables are "registered" by this function.  It will add
  275.    them to the symbol table (sc_obarray) and set their initial values.  The
  276.    function is visible within the compiler as INITIALIZEVAR.
  277. */
  278.  
  279. void  sc_initializevar( symbolname, location, value )
  280.     TSCP  symbolname, *location, value;
  281. {
  282.     SCP  sp;
  283.  
  284.     sp = T_U( sc_string_2d_3esymbol( symbolname ) );
  285.         if (*sp->symbol.ptrtovalue != UNDEFINED)
  286.        fprintf( stderr,
  287.                "***** INITIALIZEVAR Duplicately defined symbol %s\n",
  288.             &(T_U(sp->symbol.name)->string.char0) );
  289.     sp->symbol.ptrtovalue = location;
  290.     *location = value;
  291.     sc_globals = addtoSCPTRS( sc_globals, location );
  292. }
  293.  
  294. /* Global TSCP's declared in languages other than Scheme are registered with
  295.    the garbage collector by the following function.  N.B.  The garbage
  296.    collector may reloacte objects pointed to by these cells.
  297. */
  298.  
  299. void  sc_global_TSCP( location )
  300.     TSCP  *location;
  301. {
  302.     sc_globals = addtoSCPTRS( sc_globals, location );
  303. }
  304.  
  305. /* Compiled constants which are constructed from the heap during initialization
  306.    must be "registered" with the runtime system so that they will not be
  307.    treated as garbage.  This function is visible as CONSTANTEXP within the
  308.    compiler.
  309. */
  310.  
  311. void  sc_constantexp( constantaddress )
  312.     TSCP  *constantaddress;
  313. {
  314.     sc_constants = addtoSCPTRS( sc_constants, constantaddress );
  315. }
  316.  
  317. /* Strings are converted to symbols by the following function.  It will examine
  318.    the obarray to see if an identifier with the same name already exists.  If
  319.    it does then it will return a pointer to that symbol.  If not then it will
  320.    either add the symbol to the table or return #F as determined by the
  321.    value of add.
  322. */
  323.  
  324. static TSCP  stringtosymbol( symbolstring, add )
  325.     TSCP  symbolstring, add;
  326. {
  327.     TSCP  tp, cell;
  328.     SCP  sp, utp;
  329.     int  x, *oldp, *newp, *endnewp;
  330.     PATSCP  buckets;  
  331.  
  332.     newp = (int*)T_U( symbolstring );
  333.     endnewp = newp+(T_U( symbolstring )->string.length+4)/4;
  334.     x = 0;
  335.     do  x = x ^ *newp;  while  (newp++ != endnewp);
  336.     if (x < 0) x = -x;
  337.     x = x % T_U( sc_obarray )->vector.length;
  338.     buckets = &T_U( sc_obarray )->vector.element0;
  339.     tp = buckets[ x ];
  340.     while  (tp != EMPTYLIST)  {
  341.        utp = T_U( tp );
  342.        oldp = (int*)(T_U( T_U( utp->pair.car )->symbol.name ));
  343.        newp = (int*)(T_U( symbolstring ));
  344.        while  (*oldp++ == *newp)
  345.           if  (newp++ == endnewp)  return( utp->pair.car );
  346.        tp = utp->pair.cdr;
  347.     }
  348.     if ((add == EMPTYLIST) || (add == FALSEVALUE))
  349.        return( FALSEVALUE );
  350.     cell = sc_cons( EMPTYLIST, EMPTYLIST );
  351.     MUTEXON;
  352.     sp = sc_allocateheap( SYMBOLSIZE, SYMBOLTAG, 0 );
  353.     sp->symbol.name = symbolstring;
  354.     sp->symbol.ptrtovalue = &sp->symbol.value;
  355.     sp->symbol.value = UNDEFINED;
  356.     sp->symbol.propertylist = EMPTYLIST;
  357.     PAIR_CAR( cell ) = U_T( sp, EXTENDEDTAG );
  358.     PAIR_CDR( cell ) = buckets[ x ];
  359.     sc_setgeneration( &buckets[ x ], cell );
  360.     MUTEXOFF;
  361.     return( U_T( sp, EXTENDEDTAG ) );
  362. }    
  363.  
  364. /* The following function implements STRING->SYMBOL.  */
  365.  
  366. TSCP  sc_string_2d_3esymbol_v;
  367.  
  368. TSCP  sc_string_2d_3esymbol( symbolstring )
  369.     TSCP  symbolstring;
  370. {
  371.     if  ((TSCPTAG( symbolstring ) != EXTENDEDTAG) ||
  372.          (T_U( symbolstring )->string.tag != STRINGTAG))
  373.        sc_error( "STRING->SYMBOL", "Argument is not a STRING", 0 );
  374.     return( stringtosymbol( symbolstring, TRUEVALUE ) );
  375. }
  376.  
  377. /* The following function implements STRING->UNINTERNED-SYMBOL.  */
  378.  
  379. TSCP  sc_d_2dsymbol_ab4b4447_v;
  380.  
  381. TSCP  sc_d_2dsymbol_ab4b4447( symbolstring )
  382.     TSCP  symbolstring;
  383. {
  384.     SCP  sp;
  385.  
  386.     if  ((TSCPTAG( symbolstring ) != EXTENDEDTAG) ||
  387.          (T_U( symbolstring )->string.tag != STRINGTAG))
  388.        sc_error( "STRING->UNINTERNED-SYMBOL?",
  389.                  "Argument is not a STRING", 0 );
  390.     MUTEXON;
  391.     sp = sc_allocateheap( SYMBOLSIZE, SYMBOLTAG, 0 );
  392.     sp->symbol.name = symbolstring;
  393.     sp->symbol.ptrtovalue = &sp->symbol.value;
  394.     sp->symbol.value = UNDEFINED;
  395.     sp->symbol.propertylist = EMPTYLIST;
  396.     MUTEXOFF;
  397.     return( U_T( sp, EXTENDEDTAG ) );
  398. }    
  399.  
  400. /* The following function implements UNINTERNED-SYMBOL?.  */
  401.  
  402. TSCP  sc_uninterned_2dsymbol_3f_v;
  403.  
  404. TSCP  sc_uninterned_2dsymbol_3f( symbol )
  405.     TSCP  symbol;
  406. {
  407.     if  ((TSCPTAG( symbol ) != EXTENDEDTAG) ||
  408.          (T_U( symbol )->symbol.tag != SYMBOLTAG))
  409.        sc_error( "UNINTERNED-SYMBOL?", "Argument is not a SYMBOL", 0 );
  410.     return ( (stringtosymbol( T_U( symbol )->symbol.name, FALSEVALUE )
  411.           == symbol) ? FALSEVALUE : TRUEVALUE );
  412. }
  413.  
  414. /* The command line arguments passed to a program with a Scheme main are
  415.    formed into a list of strings by the following function.  It is accessed
  416.    as CLARGUMENTS within the compiler.  If an argument of the form: -scm <name>
  417.    is provided, then a list of command line arguments will not be
  418.    returned, and the function <name> will be invoked as the "main" program
  419.    with the command line arguments.  All flags of the form:  -sc... <value>
  420.    are reserved for use of the Scheme system and will be deleted from the
  421.    command line.  If this function is called at initialization, then we
  422.    know that the stack will be above or equal to &argv and sc_stackbase will
  423.    be set accordingly.
  424. */
  425.  
  426. TSCP  sc_clarguments( argc, argv )
  427.     int  argc;
  428.     char  *argv[];
  429. {
  430.     int  i;
  431.     TSCP  argl, main;
  432.  
  433.     argl = EMPTYLIST;
  434.     main = FALSEVALUE;
  435.     i = 0;
  436.     while  (i < argc)  {
  437.        if  (strcmp( argv[ i ], "-scm" ) == 0)  {
  438.           main = sc_string_2d_3esymbol(
  439.                       sc_cstringtostring( argv[ ++i ] ) );
  440.        }
  441.        else  if  (strncmp( argv[ i ], "-sc", 3 ) == 0)  {
  442.           i++;
  443.        }
  444.        else  {
  445.           argl = sc_cons( sc_cstringtostring( argv[ i ] ), argl );
  446.        }
  447.        i++;
  448.     }
  449.     argl = scrt1_reverse( argl );
  450.     sc_stackbase = ((int*)&argc)+2;
  451.     if  (main != FALSEVALUE)  {
  452.        sc_apply_2dtwo( *T_U( main )->symbol.ptrtovalue,
  453.                        sc_cons( argl, EMPTYLIST ) );
  454.        SCHEMEEXIT();
  455.     }
  456.     return( argl );
  457. }
  458.  
  459. /* Argument conversion for calling C external procedures is provided by the
  460.    following functions.  A character is converted to a C character by the
  461.    following function.
  462. */
  463.  
  464. char  sc_tscp_char( p )
  465.     TSCP  p;
  466. {
  467.     if  (TSCPIMMEDIATETAG( p ) != CHARACTERTAG)
  468.        sc_error( "TSCP_CHAR", "Argument is not a CHARACTER: ~s", 1, p );
  469.     return(  CHAR_C( p ) );
  470. }
  471.  
  472. /* The a fixed integer or a floating point number is converted to an integer.
  473.    by the following function.
  474. */
  475.  
  476. int  sc_tscp_int( p )
  477.     TSCP  p;
  478. {
  479.     switch  TSCPTAG( p )  {
  480.        case FIXNUMTAG:
  481.         return( FIXED_C( p ) );
  482.         break;
  483.        case EXTENDEDTAG:
  484.             if  (TX_U( p )->extendedobj.tag == FLOATTAG)
  485.            return ROUND( FLOAT_VALUE( p ) );
  486.         break;
  487.     }
  488.     sc_error( "TSCP_INT", "Argument cannot be converted to C int", 0 );
  489. }
  490.  
  491. /* The a fixed integer or a floating point number is converted to an integer.
  492.    by the following function.  The special case testing is present as many C
  493.    compilers do not correctly cast double <-> unsigned.
  494. */
  495.  
  496. unsigned  sc_tscp_unsigned( p )
  497.     TSCP  p;
  498. {
  499.     double  v;
  500.  
  501.     switch  TSCPTAG( p )  {
  502.        case FIXNUMTAG:
  503.         return( (unsigned)FIXED_C( p ) );
  504.         break;
  505.        case EXTENDEDTAG:
  506.             if  (TX_U( p )->extendedobj.tag == FLOATTAG)  {
  507.            v = TX_U( p )->FLOATUTYPE.value;
  508.            if  (v <= (double)(0x7fffffff))
  509.               return( (unsigned)ROUND( v ) );
  510.            else
  511.               return( (unsigned)ROUND( v-((double)(0x40000000))*2.0 ) |
  512.                      0x80000000 );
  513.         }
  514.         break;
  515.     }
  516.     sc_error( "TSCP_UNSIGNED",
  517.           "Argument cannot be converted to C unsigned", 0 );
  518. }
  519.  
  520. /* Numbers, strings, and procedures are converted to C pointers by the
  521.    following function.
  522. */
  523.  
  524. unsigned  sc_tscp_pointer( p )
  525.     TSCP  p;
  526. {
  527.     SCP  s;
  528.     double  v;
  529.  
  530.     switch  TSCPTAG( p )  {
  531.        case FIXNUMTAG:
  532.         return( (unsigned)FIXED_C( p ) );
  533.         break;
  534.        case EXTENDEDTAG:
  535.            s = T_U( p );
  536.         switch  (s->extendedobj.tag)  {
  537.            case STRINGTAG:
  538.               return( (unsigned)&s->string.char0 );
  539.               break;
  540.            case PROCEDURETAG:
  541.               return( sc_procedureaddress( p ) );
  542.               break;
  543.            case FLOATTAG:
  544.               v = TX_U( p )->FLOATUTYPE.value;
  545.               if  (v <= (double)(0x7fffffff))
  546.                  return( (unsigned int)( v ) );
  547.               else
  548.                  return( (unsigned int)( v-((double)(0x40000000))*2.0 ) |
  549.                         0x80000000 );
  550.               break;
  551.         }
  552.         break;
  553.     }
  554.     sc_error( "TSCP_POINTER", "Argument cannot be converted to C pointer",
  555.           0 );
  556. }
  557.     
  558. /* The following function produces a double value from a Scheme pointer. */
  559.  
  560. double  sc_tscp_double( p )
  561.     TSCP  p;
  562. {
  563.     switch  TSCPTAG( p )  {
  564.        case FIXNUMTAG:
  565.         return( (double)(FIXED_C( p )) );
  566.         break;
  567.        case EXTENDEDTAG:
  568.             if  (TX_U( p )->extendedobj.tag == FLOATTAG)
  569.            return( TX_U( p )->FLOATUTYPE.value );
  570.         break;
  571.     }
  572.     sc_error( "TSCP_DOUBLE", "Argument cannot be converted to C double",
  573.           0 );
  574. }
  575.  
  576. /* The following function converts an integer returned by C into either a
  577.    fixed or float value.
  578. */
  579.  
  580. TSCP  sc_int_tscp( n )
  581.     int  n;
  582. {
  583.     if  (n <= 0x1fffffff  &&  n >= -0x1fffffff)
  584.        return( C_FIXED( n ) );
  585.     return( MAKEFLOAT( (double)n ) );
  586. }
  587.  
  588. /* The following function converts an unsigned returned by C into either a
  589.    fixed or float value.   The special case testing is present as many C
  590.    compilers do not correctly cast double <-> unsigned. 
  591. */
  592.  
  593. TSCP  sc_unsigned_tscp( n )
  594.     unsigned  n;
  595. {
  596.     if  (n <= 0x1fffffff)  return( C_FIXED( n ) );
  597.     if  (n & 0x80000000)
  598.        return( MAKEFLOAT( (double)(n & 0x7fffffff)+
  599.                      ((double)( 0x40000000 ))*2.0 ) );
  600.     return( MAKEFLOAT( (double)n ) );
  601. }
  602.  
  603. /* The address of a procedure is returned by the following function. */
  604.  
  605. unsigned  sc_procedureaddress( pp )
  606.     TSCP  pp;
  607. {
  608.     return( (unsigned)(TX_U( pp )->procedure.code) );
  609. }
  610.  
  611. /* The following routine is called to push an entry onto the debug stack. */
  612.  
  613. void  sc_pushtrace( stp, procedure )
  614.     struct STACKTRACE  *stp;
  615.     TSCP  procedure;
  616. {
  617.     stp->prevstacktrace = sc_stacktrace;
  618.     stp->procname = procedure;
  619.     sc_stacktrace = stp;
  620. }
  621.  
  622. /* The following routine is called following a tail call within EXEC to
  623.    update the values saved in the trace record.
  624. */
  625.  
  626. void  sc_looptrace( stp, exp, env )
  627.     struct STACKTRACE  *stp;
  628.     TSCP  exp, env;
  629. {
  630.     stp->exp = exp;
  631.     stp->procname = env;
  632. }
  633.  
  634. /* The following routine pops an entry off the debug stack. */
  635.  
  636. TSCP  sc_poptrace( stp, exp )
  637.     struct STACKTRACE  *stp;
  638.     TSCP  exp;
  639. {
  640.     sc_stacktrace = stp->prevstacktrace;
  641.     return( exp );
  642. }
  643.