home *** CD-ROM | disk | FTP | other *** search
/ Stars of Shareware: Programmierung / SOURCE.mdf / programm / windows / c / xlisp21w / sources / xlsys.c < prev    next >
Encoding:
C/C++ Source or Header  |  1993-02-08  |  17.7 KB  |  698 lines
  1. /* xlsys.c - xlisp builtin system functions */
  2. /*      Copyright (c) 1985, by David Michael Betz
  3.         All Rights Reserved
  4.         Permission is granted for unrestricted non-commercial use       */
  5.  
  6. #include "xlisp.h"
  7.  
  8. /* external variables */
  9. extern FILEP tfp;
  10.  
  11. /* external symbols */
  12. extern LVAL a_subr,a_fsubr,a_cons,a_symbol;
  13. extern LVAL a_fixnum,a_flonum,a_string,a_object,a_stream;
  14. extern LVAL a_vector,a_closure,a_char,a_ustream;
  15. #ifdef RATIOS
  16. extern LVAL a_ratio, a_rational;
  17. #endif
  18. extern LVAL k_verbose,k_print;
  19. extern LVAL true;
  20. extern LVAL a_list, a_number, a_null, a_atom, a_anystream;
  21. extern LVAL s_and, s_or, s_not, s_satisfies, s_member;
  22. extern LVAL a_struct;
  23. extern LVAL s_lambda, s_function;
  24. #ifdef COMPLX
  25. extern LVAL a_complex;
  26. #endif
  27. #ifdef HASHFCNS
  28. extern LVAL a_hashtable;
  29. #endif
  30.  
  31.  
  32.  
  33. extern LVAL xlenv,xlfenv; /* Added for XLOAD mod */
  34.  
  35. /* $putpatch.c$: "MODULE_XLSYS_C_GLOBALS" */
  36.  
  37. /* xload - read and evaluate expressions from a file */
  38. LVAL xload()
  39. {
  40. #ifdef MEDMEM
  41.     char name[STRMAX];
  42. #else
  43.     char *name;
  44. #endif
  45.     int vflag,pflag;
  46.     LVAL oldenv,oldfenv;    /* TAA MOD-- code sections using these variables
  47.                                forces global environment on LOAD
  48.                                Change based on Luke Tierney's XLISP-STAT */
  49.     LVAL arg;
  50.  
  51.     /* protect some pointers */
  52.     xlstkcheck(2);
  53.     xlprotect(oldenv);
  54.     xlprotect(oldfenv);
  55.  
  56.     /* establish global environment */
  57.     oldenv = xlenv;
  58.     oldfenv = xlfenv;
  59.     xlenv = xlfenv = NIL;
  60.  
  61.  
  62.     /* get the file name */
  63. #ifdef MEDMEM
  64.     _fstrncpy(name, getstring(xlgetfname()), STRMAX);
  65.     name[STRMAX-1] = '\0';
  66. #else
  67.     name = getstring(xlgetfname());
  68. #endif
  69.     /* get the :verbose flag */ /* TAA MOD to simplify */
  70.     vflag = xlgetkeyarg(k_verbose,&arg) ? (arg != NIL) : TRUE;
  71.  
  72.     /* get the :print flag */ /* TAA MOD to simplify */
  73.     pflag = xlgetkeyarg(k_print,&arg) ? (arg != NIL) : FALSE;
  74.  
  75.     xllastarg();
  76.  
  77.     /* load the file, check for success */
  78.     arg = xlload(name,vflag,pflag) ? true : NIL;
  79.  
  80.     /* restore environment */
  81.     xlenv = oldenv;
  82.     xlfenv = oldfenv;
  83.  
  84.     /* restore the stack */
  85.     xlpopn(2);
  86.  
  87.     /* return success flag */
  88.     return arg;
  89.  
  90. }
  91.  
  92. /* xtranscript - open or close a transcript file */
  93. LVAL xtranscript()
  94. {
  95. #ifdef MEDMEM
  96.     char name[STRMAX];
  97. #else
  98.     char *name;
  99. #endif
  100.  
  101.     /* get the transcript file name */
  102. #ifdef MEDMEM
  103.     if (moreargs()) {
  104.         _fstrncpy(name, getstring(xlgetfname()), STRMAX);
  105.         name[STRMAX-1] = '\0';
  106.     }
  107.     else {
  108.         name[0] = '\0';
  109.     }
  110. #else
  111.     name = (moreargs() ? getstring(xlgetfname()) : NULL);
  112. #endif
  113.     xllastarg();
  114.  
  115.     /* close the current transcript */
  116.     if (tfp != CLOSED) OSCLOSE(tfp);
  117.  
  118.     /* open the new transcript */
  119. #ifdef MEDMEM
  120.     tfp = (name[0] != '\0' ? OSAOPEN(name,CREATE_WR) : CLOSED);
  121. #else
  122.     tfp = (name != NULL ? OSAOPEN(name,CREATE_WR) : CLOSED);
  123. #endif
  124.  
  125.     /* return T if a transcript is open, NIL otherwise */
  126.     return (tfp != CLOSED ? true : NIL);
  127. }
  128.  
  129. /* xtype - return type of a thing */
  130. LVAL xtype()
  131. {
  132.     LVAL arg;
  133.  
  134.     arg = xlgetarg();
  135.     xllastarg();    /* TAA MOD -- this was missing */
  136.  
  137.     switch (ntype(arg)) {
  138.     case SUBR:          return (a_subr);
  139.     case FSUBR:         return (a_fsubr);
  140.     case CONS:          return (a_cons);
  141.     case SYMBOL:        return (null(arg) ? a_list : a_symbol); /* different
  142.                                             from XLISP 2.1 */
  143.     case FIXNUM:        return (a_fixnum);
  144.     case FLONUM:        return (a_flonum);
  145.     case STRING:        return (a_string);
  146. #ifdef RATIOS
  147.     case RATIO:         return (a_ratio);
  148. #endif
  149.     case OBJECT:        return (a_object);
  150.     case STREAM:        return (a_stream);
  151.     case VECTOR:        return (a_vector);
  152.     case CLOSURE:       return (a_closure);
  153.     case CHAR:          return (a_char);
  154.     case USTREAM:       return (a_ustream);
  155.     case STRUCT:        return (getelement(arg,0));
  156. #ifdef COMPLX
  157.     case COMPLEX:       return (a_complex);
  158. #endif
  159.     /* $putpatch.c$: "MODULE_XLSYS_C_XTYPE" */
  160.     default:            xlfail("bad node type");
  161.                         return (NIL); /* eliminate warning message */
  162.     }
  163. }
  164.  
  165. int xlcvttype(arg)  /* find type of argument and return it */
  166. LVAL arg;
  167. {
  168. /*sorted into roughly most-likely-used-first order*/
  169.     if (arg == a_cons)      return CONS;
  170.     if (arg == a_list)      return CONS;    /* Synonym here */
  171.     if (arg == a_vector)    return VECTOR;
  172.     if (arg == a_string)    return STRING;
  173.     if (arg == a_symbol)    return SYMBOL;
  174.     if (arg == a_subr)      return SUBR;
  175.     if (arg == a_fsubr)     return FSUBR;
  176.     if (arg == a_fixnum)    return FIXNUM;
  177.     if (arg == a_flonum)    return FLONUM;
  178. #ifdef RATIOS
  179.     if (arg == a_ratio)     return RATIO;
  180. #endif
  181.     if (arg == a_object)    return OBJECT;
  182.     if (arg == a_stream)    return STREAM;
  183.     if (arg == a_closure)   return CLOSURE;
  184.     if (arg == a_char)      return CHAR;
  185.     if (arg == a_ustream)   return USTREAM;
  186.     if (arg == a_struct)    return STRUCT;
  187. #ifdef COMPLX
  188.     if (arg == a_complex)   return COMPLEX;
  189. #endif
  190.     if (arg == true)        return -1;  /* Fix for coerce */
  191.     return 0;
  192. }
  193.  
  194. /* typep -- check type of thing */
  195. #ifdef ANSI
  196. static int XNEAR xltypep(LVAL arg, LVAL typ)
  197. #else
  198. LOCAL xltypep(arg, typ)
  199.   LVAL arg, typ;
  200. #endif
  201. {
  202.  
  203.     if (symbolp(typ)) {
  204.  
  205.         /* everything is type T */
  206.  
  207.         if (typ == true) return TRUE;
  208.  
  209.         /* only NIL is NULL */
  210.  
  211.         if (typ == a_null) return null(arg);
  212.  
  213.         /* only atoms are ATOM */
  214.  
  215.         if (typ == a_atom) return atom(arg);
  216.  
  217.         /* two types of streams */
  218.  
  219.         if (typ == a_anystream)
  220.             return (streamp(arg) || ustreamp(arg));
  221.  
  222.         /* many ways to be a function */
  223.  
  224.         if (typ == s_function)
  225.             return (subrp(arg) || closurep(arg) || symbolp(arg) ||
  226.                 (consp(arg) && car(arg) == s_lambda));
  227.  
  228.         /* NIL is type LIST or SYMBOL */
  229.  
  230.         if (null(arg)) return (typ==a_list || typ==a_symbol);
  231.  
  232.         /* Structures are type STRUCT or the structure type */
  233.  
  234.         if (ntype(arg) == STRUCT)
  235.             return ((typ == a_struct
  236. #ifdef HASHFCNS
  237.                 && getelement(arg,0) != a_hashtable
  238. #endif
  239.                 )|| getelement(arg,0) == typ);
  240.  
  241.  
  242.         /* If typename is NUMBER, then arg can be any numeric type */
  243.  
  244.         if (typ == a_number)
  245.             return (numberp(arg)
  246. #ifdef COMPLX
  247.                 || complexp(arg)
  248. #endif
  249.                 );
  250.  
  251. #ifdef RATIOS
  252.         /* if typename is RATIONAL then arg can be fixnum or ratio */
  253.  
  254.         if (typ == a_rational)
  255.             return (fixp(arg) || ratiop(arg));
  256. #endif
  257.  
  258.         /* otherwise the typename must be the same as the type of the
  259.                 object (as would be returned by TYPE-OF) */
  260.  
  261.         return (ntype(arg) == xlcvttype(typ));
  262.     }
  263.     /* type specifier is a list */
  264.     if (consp(typ)) {
  265.         LVAL fn = car(typ);
  266.         LVAL lst = cdr(typ);
  267.  
  268.         if (fn == s_not) {  /* (not spec) */
  269.             if (!consp(lst) || !atom(cdr(lst))) goto bad_type;
  270.             return !xltypep(arg, car(lst));
  271.         }
  272.         if (fn == s_satisfies) { /* (satisfies predicatefn) */
  273.             if (!consp(lst) || !atom(cdr(lst))) goto bad_type;
  274. #ifdef KEYARG
  275.             return dotest1(arg, car(lst), NIL);
  276. #else
  277.             return dotest1(arg, car(lst));
  278. #endif
  279.         }
  280.         if (fn == a_object) { /* (object class) */
  281.             if (!consp(lst) || !atom(cdr(lst))) goto bad_type;
  282.             lst = car(lst);
  283.             return (objectp(arg) &&
  284.                 (symbolp(lst) ? getvalue(lst) : lst) == getclass(arg));
  285.         }
  286.         if (fn == s_and) {  /* (and {spec}) */
  287.             for (; consp(lst); lst = cdr(lst))
  288.                 if (!xltypep(arg,car(lst))) return FALSE;
  289.             return TRUE;
  290.         }
  291.         if (fn == s_or) {   /* (or {spec}) */
  292.             for (; consp(lst); lst = cdr(lst))
  293.                 if (xltypep(arg,car(lst))) return TRUE;
  294.             return FALSE;
  295.         }
  296.         if (fn == s_member) {   /* (member {args}) */
  297.             for (; consp(lst); lst = cdr(lst))
  298.                 if (eql(car(lst),arg)) return TRUE;
  299.             return FALSE;
  300.         }
  301.     }
  302. bad_type:
  303.     xlerror("bad type specifier", typ);
  304.     return FALSE; /* keep compilers happy */
  305. }
  306.  
  307. LVAL xtypep()
  308. {
  309.     LVAL arg, typ;
  310.  
  311.     arg = xlgetarg();
  312.     typ = xlgetarg();
  313.     xllastarg();
  314.  
  315.     return (xltypep(arg, typ) ? true : NIL);
  316. }
  317.  
  318.  
  319.  
  320.  
  321. #ifdef ANSI
  322. static LVAL XNEAR listify(LVAL arg)  /* arg must be vector or string */
  323. #else
  324. LOCAL LVAL listify(arg) /* arg must be vector or string */
  325. LVAL arg;
  326. #endif
  327. {
  328.     LVAL val;
  329.     unsigned i;
  330.  
  331.     xlsave1(val);
  332.  
  333.     if (ntype(arg) == VECTOR) {
  334.         for (i = getsize(arg); i-- > 0; )
  335.             val = cons(getelement(arg,i),val);
  336.     }
  337.     else {  /* a string */
  338.         for (i = getslength(arg); i-- > 0; )
  339.             val = cons(cvchar(getstringch(arg,i)),val);
  340.     }
  341.  
  342.     xlpop();
  343.     return (val);
  344. }
  345.  
  346. #ifdef ANSI
  347. static LVAL XNEAR vectify(LVAL arg)  /* arg must be string or cons */
  348. #else
  349. LOCAL LVAL vectify(arg) /* arg must be string or cons */
  350. LVAL arg;
  351. #endif
  352. {
  353.     LVAL val,temp;
  354.     unsigned i,l;
  355.  
  356.     if (ntype(arg) == STRING) {
  357.         l = getslength(arg);
  358.         val = newvector(l);
  359.         for (i=0; i < l; i++) setelement(val,i,cvchar(getstringch(arg,i)));
  360.     }
  361.     else {  /* a cons */
  362.         val = arg;
  363.         for (l = 0; consp(val);) { /* get length */
  364.             val = cdr(val);
  365.             l++;
  366.             if (l > MAXSLEN) xltoolong();
  367.         }
  368.         val = newvector(l);
  369.         temp = arg;
  370.         for (i = 0; i < l; i++) {
  371.             setelement(val,i,car(temp));
  372.             temp = cdr(temp);
  373.         }
  374.     }
  375.         return val;
  376. }
  377.  
  378. #ifdef ANSI
  379. static LVAL XNEAR stringify(LVAL arg)
  380. #else
  381. LOCAL LVAL stringify(arg)   /* arg must be vector or cons */
  382. LVAL arg;
  383. #endif
  384. {
  385.     LVAL val,temp;
  386.     unsigned i,l;
  387.  
  388.     if (ntype(arg) == VECTOR) {
  389.         l = getsize(arg);
  390.         val = newstring(l);
  391.         for (i=0; i < l; i++) {
  392.             temp = getelement(arg,i);
  393.             if (ntype(temp) != CHAR) goto failed;
  394.             val->n_string[i] = getchcode(temp);
  395.         }
  396.         val->n_string[l] = 0;
  397.         return val;
  398.     }
  399.     else {  /* must be cons */
  400.         val = arg;
  401.         for (l = 0; consp(val);) {
  402.             if (ntype(car(val)) != CHAR) goto failed;
  403.             val = cdr(val); /* get length */
  404.             l++;
  405.             if (l > MAXSLEN) xltoolong();
  406.         }
  407.  
  408.         val = newstring(l);
  409.         temp = arg;
  410.         for (i = 0; i < l; i++) {
  411.             val->n_string[i] = getchcode(car(temp));
  412.             temp = cdr(temp);
  413.         }
  414.         val->n_string[l] = 0;
  415.         return val;
  416.     }
  417. failed:
  418.     xlerror("can't make into string", arg);
  419.     return (NIL);   /* avoid compiler warnings */
  420. }
  421.  
  422.  
  423.  
  424. /* coerce function */
  425. LVAL xcoerce()
  426. {
  427.     LVAL type, arg, temp;
  428.     int newtype,oldtype;
  429.  
  430.     arg = xlgetarg();
  431.     type = xlgetarg();
  432.     xllastarg();
  433.  
  434.     if ((newtype = xlcvttype(type)) == 0) goto badconvert;
  435.  
  436.     oldtype = (arg==NIL? CONS: ntype(arg)); /* TAA fix */
  437.  
  438.     if (newtype == -1 || oldtype == newtype) return (arg);  /* easy case! */
  439.  
  440.     switch (newtype) {
  441.         case CONS:
  442.             if ((oldtype == STRING)||(oldtype == VECTOR))
  443.                 return (listify(arg));
  444.             break;
  445.         case STRING:
  446.             if ((oldtype == CONS)||(oldtype == VECTOR))
  447.                 return (stringify(arg));
  448.             break;
  449.         case VECTOR:
  450.             if ((oldtype == STRING)||(oldtype == CONS))
  451.                 return (vectify(arg));
  452.             break;
  453.         case CHAR:
  454.             if (oldtype == FIXNUM) return cvchar((int)getfixnum(arg));
  455.             else if ((oldtype == STRING) && (getslength(arg) == 1))
  456.                 return cvchar(getstringch(arg,0));
  457.             else if (oldtype == SYMBOL) {
  458.                 temp = getpname(arg);
  459.                 if (getslength(temp) == 1) return cvchar(getstringch(temp,0));
  460.             }
  461.             break;
  462.         case FLONUM:
  463.             if (oldtype == FIXNUM) return (cvflonum((FLOTYPE) getfixnum(arg)));
  464. #ifdef RATIOS
  465.             else if (oldtype == RATIO)
  466.                 return (cvflonum (getnumer(arg) / (FLOTYPE) getdenom(arg)));
  467. #endif
  468.             break;
  469. #ifdef COMPLX
  470.         case COMPLEX:
  471.             if (oldtype == FIXNUM)
  472.                 return (arg);   /* nothing happens */
  473. #ifdef RATIOS
  474.             else if (oldtype == RATIO)
  475.                 return newdcomplex(getnumer(arg)/(FLOTYPE)getdenom(arg), (FLOTYPE) 0.0);
  476. #endif
  477.             else if (oldtype == FLONUM)
  478.                 return newdcomplex(getflonum(arg), (FLOTYPE) 0.0);
  479.             break;
  480. #endif
  481.     }
  482.  
  483.  
  484. badconvert:
  485.     xlerror("illegal coersion",arg);
  486.     return (NIL);   /* avoid compiler warnings */
  487. }
  488.  
  489.  
  490.  
  491. #ifdef ADDEDTAA
  492. /* xgeneric - get generic representation of thing */
  493. /* TAA addition */
  494. LVAL xgeneric()
  495. {
  496.     LVAL arg,acopy;
  497.  
  498.     arg = xlgetarg();
  499.     xllastarg();
  500.  
  501.     switch (ntype(arg)) {
  502.     case CONS: case USTREAM:
  503.         return (cons(car(arg),cdr(arg)));
  504.     case SYMBOL: case OBJECT: case VECTOR: case CLOSURE:
  505.     case STRUCT:
  506. #ifdef COMPLX
  507.     case COMPLEX:
  508. #endif
  509.         acopy = newvector(getsize(arg));
  510.         MEMCPY(acopy->n_vdata, arg->n_vdata, getsize(arg)*sizeof(LVAL));
  511.         return (acopy);
  512.     case STRING: /* make a copy of the string */
  513.         acopy = newstring(getslength(arg));
  514.         MEMCPY(getstring(acopy), getstring(arg), getslength(arg)+1);
  515.         return (acopy);
  516.     case FIXNUM: case FLONUM: case CHAR:
  517. #ifdef RATIOS
  518.     case RATIO:
  519. #endif
  520.         return (arg); /* it hardly matters to copy these */
  521.     default:    xlbadtype(arg);
  522.         return (NIL);   /* avoid compiler warnings */
  523.     }
  524. }
  525.  
  526. #endif
  527.  
  528.  
  529. /* xbaktrace - print the trace back stack */
  530. LVAL xbaktrace()
  531. {
  532.     LVAL num;
  533.     int n;
  534.  
  535.     if (moreargs()) {
  536.         num = xlgafixnum();
  537.         n = (int)getfixnum(num);
  538.     }
  539.     else
  540.         n = -1;
  541.     xllastarg();
  542.     xlbaktrace(n);
  543.     return (NIL);
  544. }
  545.  
  546. /* xexit - get out of xlisp */
  547. LVAL xexit()
  548. {
  549.     xllastarg();
  550.     wrapup();
  551.     return (NIL); /* never returns */
  552. }
  553.  
  554. /* xpeek - peek at a location in memory */
  555. LVAL xpeek()
  556. {
  557.     LVAL num;
  558.     OFFTYPE *adr;   /* TAA MOD so that data fetched is sizeof(LVAL *) */
  559.  
  560.     /* get the address */
  561.     num = xlgafixnum(); adr = (OFFTYPE *)getfixnum(num);
  562.     xllastarg();
  563.  
  564.     /* return the value at that address */
  565.     return (cvfixnum((FIXTYPE)*adr));
  566. }
  567.  
  568. /* xpoke - poke a value into memory */
  569. LVAL xpoke()
  570. {
  571.     LVAL val;
  572.     OFFTYPE *adr;   /* TAA MOD so that data fetched is sizeof(LVAL *) */
  573.  
  574.     /* get the address and the new value */
  575.     val = xlgafixnum(); adr = (OFFTYPE *)getfixnum(val);
  576.     val = xlgafixnum();
  577.     xllastarg();
  578.  
  579.     /* store the new value */
  580.     *adr = (OFFTYPE)getfixnum(val);
  581.  
  582.     /* return the new value */
  583.     return (val);
  584. }
  585.  
  586. /* xaddrs - get the address of an XLISP node */
  587. LVAL xaddrs()
  588. {
  589.     LVAL val;
  590.  
  591.     /* get the node */
  592.     val = xlgetarg();
  593.     xllastarg();
  594.  
  595.     /* return the address of the node */
  596.     return (cvfixnum((FIXTYPE)val));
  597. }
  598.  
  599. #ifdef RANDOM
  600.  
  601. extern LVAL a_randomstate, s_randomstate, k_data;
  602.  
  603.  
  604. LVAL newrandom(seed)
  605.  long seed;
  606. {
  607.     LVAL result;
  608.  
  609.     result = newstruct(a_randomstate, 1);
  610.     xlprot1(result);
  611.  
  612.     setelement(result, 1, cvfixnum((FIXTYPE)seed));
  613.  
  614.     xlpop();
  615.  
  616.     return result;
  617. }
  618.  
  619.  
  620. /* make-random-state function */
  621. LVAL xmakerandom()
  622. {
  623.     LVAL arg;
  624.  
  625.     /*argument is either random state, t for randomize, or nil/absent
  626.         to use *random-state* */
  627.  
  628.     /* secret agenda: there could also be no regular arguments but a
  629.         single keyword argument (:DATA) which is the seed!
  630.         I'll leave it to the curious to figure out why. */
  631.  
  632.     if (moreargs()) {
  633.         arg = xlgetarg();
  634.         if (arg == k_data) {
  635.             arg = xlgafixnum();
  636.             xllastarg();
  637.             return newrandom((long)getfixnum(arg));
  638.         }
  639.         xllastarg();
  640.         if (arg == true) return newrandom(real_tick_count());
  641.         if (null(arg)) arg = getvalue(s_randomstate);
  642.     }
  643.     else arg = getvalue(s_randomstate);
  644.  
  645.     if ((!structp(arg)) || getelement(arg,0) != a_randomstate
  646.         || !fixp(getelement(arg,1))) {
  647.         xlbadtype(arg);
  648.     }
  649.  
  650.     return newrandom((long)getfixnum(getelement(arg,1)));
  651. }
  652.  
  653. /* RANDOM Function */
  654.  
  655. LVAL xrand()
  656. {
  657.     LVAL state, value;
  658.     long rand;
  659.     int isfixed;
  660.  
  661.     value = xlgetarg();
  662.  
  663.     if (fixp(value)) {
  664.         isfixed = TRUE;
  665.         if (getfixnum(value) <= 0) xlerror("range error", value);
  666.     }
  667.     else if (floatp(value)) {
  668.         isfixed = FALSE;
  669.         if (getflonum(value) <= 0.0) xlerror("range error", value);
  670.     }
  671.     else xlbadtype(value);
  672.  
  673.     if (moreargs()) {   /* seed provided */
  674.         state = xlgetarg();
  675.         xllastarg();
  676.     }
  677.     else {  /* use global seed */
  678.         state = getvalue(s_randomstate);
  679.     }
  680.  
  681.     if ((!structp(state)) || getelement(state,0) != a_randomstate
  682.         || !fixp(getelement(state,1))) {
  683.         xlbadtype(state);
  684.     }
  685.  
  686.     rand = osrand((long)getfixnum(getelement(state,1))); /* generate number*/
  687.  
  688.     setelement(state, 1, cvfixnum((FIXTYPE)rand)); /* put seed away */
  689.  
  690.     if (isfixed)
  691.         return cvfixnum((FIXTYPE)rand % getfixnum(value));
  692.     else
  693.         /* I'm tossing the upper 7 bits which, while it increases granularity,
  694.             will make the numbers more "random", I hope */
  695.         return cvflonum((FLOTYPE)(rand&0xffffffL)/(FLOTYPE)0x1000000L*getflonum(value));
  696. }
  697. #endif
  698.