/* $Header$ */ /* * Copyright © 1988-2004 Keith Packard and Bart Massey. * All Rights Reserved. See the file COPYING in this directory * for licensing information. */ /* * toplevel.c * * provide builtin functions for the Toplevel namespace */ #include #include #include #include "builtin.h" void import_Toplevel_namespace() { ENTER (); static const struct fbuiltin_0 funcs_0[] = { { do_time, "time", "i", "", "\n" " int time ()\n" "\n" " Return seconds since Jan 1, 1970 00:00 GMT\n" }, { 0 } }; static const struct fbuiltin_1 funcs_1[] = { { do_abs, "abs", "R", "R", "\n" " real abs (real r)\n" "\n" " Return absolute value of 'r'.\n" }, { do_bit_width, "bit_width", "i", "i", "\n" " int bit_width (int i)\n" "\n" " Return width of binary representation of abs('i').\n" }, { do_ceil, "ceil", "i", "R", "\n" " int ceil (real r)\n" "\n" " Return the nearest integer no smaller than 'r'.\n" }, { do_denominator, "denominator", "i", "r", " int denominator (rational r)\n" "\n" " Return the denominator of 'r'\n" }, { do_dim, "dim", "i", "A*p", "\n" " int dim (poly[*] a)\n" "\n" " Return the dimension of 'a'.\n" }, { do_dims, "dims", "A*i", "Ap", "\n" " int[*] dims (poly[] a)\n" "\n" " Return an array containing the list of dimensions of 'a'.\n" }, { do_exit, "exit", "v", "i", "\n" " void exit (int i)\n" "\n" " Exit from the nickle environment with code 'i'.\n" }, { do_exponent, "exponent", "i", "R", "\n" " int exponent (real r)\n" "\n" " Return the exponent of the imprecise value 'r'.\n" }, { do_floor, "floor", "i", "R", "\n" " int floor (real r)\n" "\n" " Return the nearest integer no larger than 'r'.\n" }, { do_func_args, "func_args", "i", "p", "\n" " int func_args (poly f)\n" "\n" " Return the number of arguments required by function 'f'.\n" }, { do_is_array, "is_array", "b", "p", "\n" " bool is_array (poly v)\n" "\n" " Return whether 'v' is an array value.\n" }, { do_is_continuation, "is_continuation", "b", "p" , "\n" " bool is_continuation (poly v)\n" "\n" " Return whether 'v' is an continuation value.\n" }, { do_is_file, "is_file", "b", "p" , "\n" " bool is_file (poly v)\n" "\n" " Return whether 'v' is an file value.\n" }, { do_is_func, "is_func", "b", "p" , "\n" " bool is_func (poly v)\n" "\n" " Return whether 'v' is an func value.\n" }, { do_is_int, "is_int", "b", "p" , "\n" " bool is_int (poly v)\n" "\n" " Return whether 'v' is an int value.\n" }, { do_is_number, "is_number", "b", "p" , "\n" " bool is_number (poly v)\n" "\n" " Return whether 'v' is an numeric value.\n" }, { do_is_rational, "is_rational", "b", "p" , "\n" " bool is_rational (poly v)\n" "\n" " Return whether 'v' is an rational value.\n" }, { do_is_ref, "is_ref", "b", "p" , "\n" " bool is_ref (poly v)\n" "\n" " Return whether 'v' is an ref value.\n" }, { do_is_semaphore, "is_semaphore", "b", "p" , "\n" " bool is_semaphore (poly v)\n" "\n" " Return whether 'v' is an semaphore value.\n" }, { do_is_string, "is_string", "b", "p" , "\n" " bool is_string (poly v)\n" "\n" " Return whether 'v' is an string value.\n" }, { do_is_struct, "is_struct", "b", "p" , "\n" " bool is_struct (poly v)\n" "\n" " Return whether 'v' is an struct value.\n" }, { do_is_thread, "is_thread", "b", "p" , "\n" " bool is_thread (poly v)\n" "\n" " Return whether 'v' is an thread value.\n" }, { do_is_bool, "is_bool", "b", "p" , "\n" " bool is_bool (poly v)\n" "\n" " Return whether 'v' is an bool value.\n" }, { do_is_void, "is_void", "b", "p" , "\n" " bool is_void (poly v)\n" "\n" " Return whether 'v' is an void value.\n" }, { do_is_uninit, "is_uninit", "b", "*p", "\n" " bool is_uninit (*poly r)\n" "\n" " Return whether 'r' references uninitialized storage.\n" }, { do_make_uninit, "make_uninit", "v", "*p", "\n" " void make_uninit (*poly r)\n" "\n" " Makes 'r' reference uninitialized storage.\n" }, { do_mantissa, "mantissa", "r", "R", "\n" " rational mantissa (real r)\n" "\n" " Return the mantissa of 'r' as a rational between 0 and 1.\n" }, { do_numerator, "numerator", "i", "r", "\n" " int numerator (rational r)\n" "\n" " Return the numerator of 'r'.\n" }, { do_precision, "precision", "i", "R", "\n" " int precision (real r)\n" "\n" " Return the number of bits in the\n" " representation of the mantissa of 'r'.\n" }, { do_profile, "profile", "b", "b", "\n" " bool profile (bool enable)\n" "\n" " Set profiling on/off.\n" " Returns previous profiling state.\n" }, { do_reference, "reference", "*p", "p", "\n" " *poly reference (poly value)\n" "\n" " Returns &value.\n" }, { do_sign, "sign", "i", "R", "\n" " int sign (real r)\n" " Return -1, 0, 1 for negative, zero or positive 'r'.\n" }, { do_sleep, "sleep", "v", "i", "\n" " void sleep (int milliseconds)\n" "\n" " Pause thread execution for 'milliseconds'.\n" }, { do_string_to_real, "string_to_real", "R", "s", "\n" " real string_to_real (string s)\n" "\n" " Parse a string representation of a numeric value.\n" }, { do_hash, "hash", "i", "p", "\n" " int hash (poly p)\n" "\n" " Return an integer based on 'p' such that any value equal\n" " to 'p' will return the same integer.\n" }, { do_hash_keys, "hash_keys", "Ap", "Hpp", "\n" " poly[] hash_keys (poly[poly] h)\n" "\n" " Return an array containing all of the key in 'h'.\n" " The order within the array is undefined.\n" }, { 0 } }; static const struct fbuiltin_2 funcs_2[] = { { do_gcd, "gcd", "i", "ii", "\n" " int gcd (int a, int b)\n" "\n" " Return the greatest common divisor of 'a' and 'b'.\n" }, { do_setjmp, "setjmp", "p", "*cp", "\n" " poly setjmp (*continuation c, poly v)\n" "\n" " On direct invocation, create a continuation and store\n" " that in *'c'. Then return 'v'.\n" " Subsequent invocations of longjmp with *'c' will appear\n" " to return from 'setjmp' with the value passed to longjmp.\n" }, { do_setdims, "setdims", "v", "ApA*i", "\n" " void setdims (poly[] a, int[*] dimensions)\n" "\n" " Set the dimensions of resizable array 'a' to 'dimensions'.\n" " dim(dimensionss) must be the same as dim(dims(a)).\n" }, { do_setdim, "setdim", "v", "A.pi", "\n" " void setdim (poly[...] a, int dimension)\n" "\n" " Set the dimension of 'a' to 'dimension'.\n" }, { do_hash_del, "hash_del", "v", "Hppp", "\n" " void hash_del (poly[poly] h, poly key)\n" "\n" " Delete any hash value in 'h' associated with 'key'.\n" }, { do_hash_test, "hash_test", "b", "Hppp", "\n" " bool hash_test (poly[poly] h, poly key)\n" "\n" " Return whether 'h' contains 'key'.\n" }, { 0 } }; static const struct fbuiltin_2j funcs_2j[] = { { do_longjmp, "longjmp", "v", "cp", "\n" " void longjmp (continuation c, poly v)\n" "\n" " Relocate execution to that saved in 'c', making the\n" " setjmp call there appear to return 'v'.\n" }, { 0 } }; static const struct fbuiltin_v funcs_v[] = { { do_imprecise, "imprecise", "R", "R.i", "\n" " real imprecise (real r)\n" " real imprecise (real r, int precision)\n" "\n" " Return an imprecise number.\n" " The precision will be 'precision' if supplied, else 256.\n" }, { do_string_to_integer, "string_to_integer", "i", "s.i", "\n" " int string_to_integer (string s)\n" " int string_to_integer (string s, int base)\n" "\n" " Parse 's' as an integer.\n" " Use 'base' if supplied, else autodetect.\n" }, { 0 } }; BuiltinFuncs0 (/*parent*/ 0, funcs_0); BuiltinFuncs1 (/*parent*/ 0, funcs_1); BuiltinFuncs2 (/*parent*/ 0, funcs_2); BuiltinFuncs2J (/*parent*/ 0, funcs_2j); BuiltinFuncsV (/*parent*/ 0, funcs_v); EXIT (); } Value do_gcd (Value a, Value b) { ENTER (); RETURN (Gcd (a, b)); } Value do_time (void) { ENTER (); RETURN (Reduce (NewInteger (Positive, NewDoubleDigitNatural ((double_digit) time(0))))); } Value do_string_to_integer (int n, Value *p) { ENTER (); char *s; int ibase; int negative = 0; Value ret = Zero; Value str = p[0]; Value base = Zero; switch(n) { case 1: break; case 2: base = p[1]; break; default: RaiseStandardException (exception_invalid_argument, "string_to_integer: wrong number of arguments", 2, NewInt (2), NewInt (n)); RETURN(Void); } s = StringChars (&str->string); while (isspace ((int)(*s))) s++; switch (*s) { case '-': negative = 1; s++; break; case '+': s++; break; } ibase = IntPart (base, "string_to_integer: invalid base"); if (!aborting) { if (ibase == 0) { if (!strncmp (s, "0x", 2) || !strncmp (s, "0X", 2)) ibase = 16; else if (!strncmp (s, "0t", 2) || !strncmp (s, "0T", 2)) ibase = 10; else if (!strncmp (s, "0b", 2) || !strncmp (s, "0B", 2)) ibase = 2; else if (!strncmp (s, "0o", 2) || !strncmp (s, "0O", 2) || *s == '0') ibase = 8; else ibase = 10; } switch (ibase) { case 2: if (!strncmp (s, "0b", 2) || !strncmp (s, "0B", 2)) s += 2; break; case 8: if (!strncmp (s, "0o", 2) || !strncmp (s, "0O", 2)) s += 2; case 10: if (!strncmp (s, "0t", 2) || !strncmp (s, "0T", 2)) s += 2; break; case 16: if (!strncmp (s, "0x", 2) || !strncmp (s, "0X", 2)) s += 2; break; } ret = atov (s, ibase); if (!aborting) { if (negative) ret = Negate (ret); } } RETURN (ret); } Value do_string_to_real (Value str) { ENTER (); RETURN (aetov (StringChars (&str->string), 10)); } Value do_imprecise (int n, Value *p) { ENTER(); Value v; int prec; v = p[0]; if (n > 1) { prec = IntPart (p[1], "imprecise: invalid precision"); if (prec <= 0) { RaiseStandardException (exception_invalid_argument, "imprecise: precision must be positive", 2, NewInt(0), p[1]); RETURN(v); } } else { if (ValueIsFloat(v)) RETURN(v); prec = DEFAULT_FLOAT_PREC; } RETURN (NewValueFloat (v, prec)); } Value do_abs (Value a) { ENTER (); if (Negativep (a)) a = Negate (a); RETURN (a); } Value do_floor (Value a) { return Floor (a); } Value do_func_args (Value a) { ENTER (); if (!ValueIsFunc (a)) { RaiseStandardException (exception_invalid_argument, "func_args: argument must be function", 2, NewInt (0), a); RETURN (Void); } RETURN (NewInt (a->func.code->base.argc)); } Value do_ceil (Value a) { return Ceil (a); } Value do_exit (Value av) { ENTER (); int code; code = IntPart (av, "Illegal exit code"); if (aborting) RETURN (Void); IoFini (); exit (code); RETURN (Void); } Value do_dim(Value av) { ENTER(); Value ret; if (av->array.ndim != 1) { RaiseStandardException (exception_invalid_argument, "dim: argument must be one-dimensional array", 2, NewInt (0), av); RETURN (Void); } ret = NewInt(ArrayLimits(&av->array)[0]); RETURN (ret); } Value do_dims(Value av) { ENTER(); Value ret; int i; int ndim = av->array.ndim; ret = NewArray(True, False, typePrim[rep_int], 1, &ndim); for (i = 0; i < ndim; i++) { Value d = NewInt(ArrayLimits(&av->array)[i]); ArrayValueSet(&ret->array, ndim - i - 1, d); } RETURN (ret); } Value do_setdims (Value av, Value dv) { ENTER (); Array *a = &av->array; Array *d = &dv->array; #define DIM_LOCAL 32 int dimLocal[DIM_LOCAL]; int *dims = a->ndim < DIM_LOCAL ? dimLocal : AllocateTemp (a->ndim * sizeof (int)); int i; if (a->ndim != ArrayNvalues(d)) { RaiseStandardException (exception_invalid_argument, "setdims: size of dimensions must match dimensionality of array", 2, NewInt (a->ndim), dv); RETURN (Void); } if (!av->array.resizable) { RaiseStandardException (exception_invalid_argument, "setdims: array must be resizable", 1, av, Void); RETURN (Void); } for (i = 0; i < a->ndim; i++) { int j = a->ndim - 1 - i; dims[j] = IntPart (ArrayValue (d,i), "setdims: invalid dimension"); if (aborting) RETURN (Void); if (dims[j] < 0) { RaiseStandardException (exception_invalid_argument, "setdims: dimensions must be non-negative", 2, NewInt (i), NewInt (dims[j])); RETURN (Void); } } ArraySetDimensions (av, dims); RETURN (Void); } Value do_setdim (Value av, Value dv) { ENTER (); int d = IntPart (dv, "setdim: invalid dimension"); if (aborting) RETURN (Void); if (d < 0) { RaiseStandardException (exception_invalid_argument, "setdim: dimension must be non-negative", 2, dv, Void); RETURN (Void); } if (!av->array.resizable) { RaiseStandardException (exception_invalid_argument, "setdim: array must be resizable", 1, av, Void); RETURN (Void); } ArrayResize (av, 0, d); RETURN (Void); } Value do_reference (Value av) { ENTER (); Value ret; ret = NewRef (NewBox (False, False, 1, typePoly), 0); RefValueSet (ret, Copy (av)); RETURN (ret); } Value do_precision (Value av) { ENTER (); unsigned prec; if (ValueIsFloat(av)) prec = av->floats.prec; else prec = 0; RETURN (NewInt (prec)); } Value do_sign (Value av) { ENTER (); if (Zerop (av)) av = Zero; else if (Negativep (av)) av = NewInt(-1); else av = One; RETURN (av); } Value do_exponent (Value av) { ENTER (); Value ret; if (!ValueIsFloat(av)) { RaiseStandardException (exception_invalid_argument, "exponent: argument must be imprecise", 2, NewInt (0), av); RETURN (Void); } ret = NewInteger (av->floats.exp->sign, av->floats.exp->mag); ret = Plus (ret, NewInt (FpartLength (av->floats.mant))); RETURN (ret); } Value do_mantissa (Value av) { ENTER (); Value ret; if (!ValueIsFloat(av)) { RaiseStandardException (exception_invalid_argument, "mantissa: argument must be imprecise", 2, NewInt (0), av); RETURN (Void); } ret = NewInteger (av->floats.mant->sign, av->floats.mant->mag); ret = Divide (ret, Pow (NewInt (2), NewInt (FpartLength (av->floats.mant)))); RETURN (ret); } Value do_numerator (Value av) { ENTER (); switch (ValueTag(av)) { case rep_int: case rep_integer: break; case rep_rational: av = NewInteger (av->rational.sign, av->rational.num); break; default: RaiseStandardException (exception_invalid_argument, "numerator: argument must be precise", 2, NewInt (0), av); av = Void; break; } RETURN (av); } Value do_denominator (Value av) { ENTER (); switch (ValueTag(av)) { case rep_int: case rep_integer: av = One; break; case rep_rational: av = NewInteger (Positive, av->rational.den); break; default: RaiseStandardException (exception_invalid_argument, "denominator: argument must be precise", 2, NewInt (0), av); av = Void; break; } RETURN (av); } Value do_bit_width (Value av) { ENTER (); switch (ValueTag(av)) { case rep_int: av = NewInt (IntWidth (ValueInt(av))); break; case rep_integer: av = NewInt (NaturalWidth (IntegerMag(av))); break; default: RaiseStandardException (exception_invalid_argument, "bit_width: argument must be integer", 2, NewInt (0), av); av = Void; break; } RETURN (av); } Value do_is_int (Value av) { ENTER (); switch (ValueTag(av)) { case rep_int: case rep_integer: av = TrueVal; break; default: av = FalseVal; break; } RETURN (av); } Value do_is_rational (Value av) { ENTER (); switch (ValueTag(av)) { case rep_int: case rep_integer: case rep_rational: av = TrueVal; break; default: av = FalseVal; break; } RETURN (av); } Value do_is_number (Value av) { ENTER (); switch (ValueTag(av)) { case rep_int: case rep_integer: case rep_rational: case rep_float: av = TrueVal; break; default: av = FalseVal; break; } RETURN (av); } Value do_is_string (Value av) { ENTER (); switch (ValueTag(av)) { case rep_string: av = TrueVal; break; default: av = FalseVal; break; } RETURN (av); } Value do_is_file (Value av) { ENTER (); switch (ValueTag(av)) { case rep_file: av = TrueVal; break; default: av = FalseVal; break; } RETURN (av); } Value do_is_thread (Value av) { ENTER (); switch (ValueTag(av)) { case rep_thread: av = TrueVal; break; default: av = FalseVal; break; } RETURN (av); } Value do_is_semaphore (Value av) { ENTER (); switch (ValueTag(av)) { case rep_semaphore: av = TrueVal; break; default: av = FalseVal; break; } RETURN (av); } Value do_is_continuation (Value av) { ENTER (); switch (ValueTag(av)) { case rep_continuation: av = TrueVal; break; default: av = FalseVal; break; } RETURN (av); } Value do_is_bool (Value av) { ENTER (); switch (ValueTag(av)) { case rep_bool: av = TrueVal; break; default: av = FalseVal; break; } RETURN (av); } Value do_is_void (Value av) { ENTER (); switch (ValueTag(av)) { case rep_void: av = TrueVal; break; default: av = FalseVal; break; } RETURN (av); } Value do_is_uninit (Value av) { ENTER (); if (!av) { RaiseStandardException (exception_invalid_argument, "do_is_uninit: invalid reference", 2, NewInt (0), av); av = Void; } else if (RefValueGet(av)) { av = FalseVal; } else { av = TrueVal; } RETURN (av); } Value do_make_uninit (Value av) { ENTER (); if (!av) { RaiseStandardException (exception_invalid_argument, "do_make_uninit: invalid reference", 2, NewInt (0), av); } else { RefValueSet(av, 0); } RETURN (Void); } Value do_is_array (Value av) { ENTER (); switch (ValueTag(av)) { case rep_array: av = TrueVal; break; default: av = FalseVal; break; } RETURN (av); } Value do_is_ref (Value av) { ENTER (); switch (ValueTag(av)) { case rep_ref: av = TrueVal; break; default: av = FalseVal; break; } RETURN (av); } Value do_is_struct (Value av) { ENTER (); switch (ValueTag(av)) { case rep_struct: av = TrueVal; break; default: av = FalseVal; break; } RETURN (av); } Value do_is_func (Value av) { ENTER (); switch (ValueTag(av)) { case rep_func: av = TrueVal; break; default: av = FalseVal; break; } RETURN (av); } Value do_hash (Value a) { return ValueHash (a); } /* hash builtins (for testing) */ Value do_hash_new (void) { return NewHash (False, typePoly, typePoly); } Value do_hash_del (Value hv, Value key) { HashDelete (hv, key); return Void; } Value do_hash_test (Value hv, Value key) { return HashTest (hv, key); } Value do_hash_keys (Value hv) { return HashKeys (hv); }