home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
OS/2 Shareware BBS: 10 Tools
/
10-Tools.zip
/
mitsch75.zip
/
scheme-7_5_17-src.zip
/
scheme-7.5.17
/
src
/
microcode
/
extern.c
< prev
next >
Wrap
C/C++ Source or Header
|
2001-03-08
|
6KB
|
200 lines
/* -*-C-*-
$Id: extern.c,v 9.38 2001/03/08 18:00:21 cph Exp $
Copyright (c) 1987-1999 Massachusetts Institute of Technology
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or (at
your option) any later version.
This program is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
*/
#include "scheme.h"
#include "prims.h"
/* Mapping between the internal and external representations of
primitives and return addresses. */
DEFINE_PRIMITIVE ("MAP-CODE-TO-MACHINE-ADDRESS", Prim_map_code_to_address, 2, 2,
"For return codes and primitives, this returns the internal\n\
representation of the return address or primitive address given the\n\
external representation.\n\
\n\
This accepts two arguments, TYPE-CODE and VALUE-CODE. TYPE-CODE is\n\
the microcode type of the object to be returned; it must be either a\n\
return address or primitive procedure type. VALUE-CODE is the index\n\
number (i.e. external representation) of the desired result.")
{
long tc, number;
PRIMITIVE_HEADER (2);
tc = (arg_nonnegative_integer (1));
number = (arg_nonnegative_integer (2));
switch (tc)
{
case TC_RETURN_CODE:
if (number > MAX_RETURN_CODE)
error_bad_range_arg (2);
PRIMITIVE_RETURN (MAKE_OBJECT (tc, number));
case TC_PRIMITIVE:
if (number > (NUMBER_OF_PRIMITIVES ()))
error_bad_range_arg (2);
PRIMITIVE_RETURN (MAKE_PRIMITIVE_OBJECT (number));
default:
error_bad_range_arg (1);
}
/*NOTREACHED*/
return (0);
}
DEFINE_PRIMITIVE ("MAP-MACHINE-ADDRESS-TO-CODE", Prim_map_address_to_code, 2, 2,
"This is the inverse operation of `map-code-to-machine-address'. Given\n\
a machine ADDRESS and a TYPE-CODE (either return code or primitive\n\
procedure), it finds the number for the external representation for\n\
the internal address.")
{
fast SCHEME_OBJECT tc;
fast SCHEME_OBJECT address;
PRIMITIVE_HEADER (2);
tc = (arg_nonnegative_integer (1));
address = (ARG_REF (2));
if ((OBJECT_TYPE (address)) != tc)
error_wrong_type_arg (2);
switch (tc)
{
case TC_RETURN_CODE:
{
fast long number = (OBJECT_DATUM (address));
if (number > MAX_RETURN_CODE)
error_bad_range_arg (2);
PRIMITIVE_RETURN (LONG_TO_UNSIGNED_FIXNUM (number));
}
case TC_PRIMITIVE:
PRIMITIVE_RETURN (LONG_TO_UNSIGNED_FIXNUM (PRIMITIVE_NUMBER (address)));
default:
error_bad_range_arg (1);
}
/*NOTREACHED*/
return (0);
}
DEFINE_PRIMITIVE ("PRIMITIVE-PROCEDURE-ARITY", Prim_primitive_procedure_arity, 1, 1,
"Given a primitive procedure, returns the number of arguments it requires.")
{
PRIMITIVE_HEADER (1);
CHECK_ARG (1, PRIMITIVE_P);
{
fast SCHEME_OBJECT primitive = (ARG_REF (1));
if ((PRIMITIVE_NUMBER (primitive))
> ((unsigned long) (NUMBER_OF_PRIMITIVES ())))
error_bad_range_arg (1);
PRIMITIVE_RETURN (LONG_TO_FIXNUM (PRIMITIVE_ARITY (primitive)));
}
}
DEFINE_PRIMITIVE ("PRIMITIVE-PROCEDURE-DOCUMENTATION",
Prim_primitive_procedure_doc, 1, 1,
"Given a primitive procedure, return its documentation string.")
{
PRIMITIVE_HEADER (1);
CHECK_ARG (1, PRIMITIVE_P);
{
SCHEME_OBJECT primitive = (ARG_REF (1));
if ((PRIMITIVE_NUMBER (primitive))
> ((unsigned long) (NUMBER_OF_PRIMITIVES ())))
error_bad_range_arg (1);
{
CONST char * answer = (PRIMITIVE_DOCUMENTATION (primitive));
PRIMITIVE_RETURN
((answer == 0)
? SHARP_F
: (char_pointer_to_string ((unsigned char *) answer)));
}
}
}
DEFINE_PRIMITIVE ("GET-PRIMITIVE-COUNTS", Prim_get_primitive_counts, 0, 0,
"Return a pair of integers which are the number of primitive procedures.\n\
The car is the count of defined primitives;\n\
the cdr is the count of undefined primitives that are referenced.")
{
PRIMITIVE_HEADER (0);
PRIMITIVE_RETURN
(cons ((LONG_TO_UNSIGNED_FIXNUM ((NUMBER_OF_PRIMITIVES ()))),
(LONG_TO_UNSIGNED_FIXNUM (0))));
}
DEFINE_PRIMITIVE ("GET-PRIMITIVE-NAME", Prim_get_primitive_name, 1, 1,
"Return the (string) name of PRIMITIVE-PROCEDURE.")
{
PRIMITIVE_HEADER (1);
{
fast SCHEME_OBJECT primitive = (ARG_REF (1));
if (! ((PRIMITIVE_P (primitive)) || (FIXNUM_P (primitive))))
error_wrong_type_arg (1);
{
fast long number = (PRIMITIVE_NUMBER (primitive));
if ((number < 0) || (number > (NUMBER_OF_PRIMITIVES ())))
error_bad_range_arg (1);
PRIMITIVE_RETURN
(char_pointer_to_string ((unsigned char *)
(PRIMITIVE_NAME (primitive))));
}
}
}
DEFINE_PRIMITIVE ("GET-PRIMITIVE-ADDRESS", Prim_get_primitive_address, 2, 2,
"Given a symbol NAME, return the primitive object of that name.\n\
ARITY is the number of arguments which the primitive should expect.\n\
If ARITY is #F, #F is returned if the primitive is not implemented,\n\
even if the name already exists.\n\
If ARITY is an integer, a primitive object will always be returned,\n\
whether the corresponding primitive is implemented or not.")
{
fast SCHEME_OBJECT name;
fast SCHEME_OBJECT arity_arg;
extern SCHEME_OBJECT EXFUN
(find_primitive, (SCHEME_OBJECT, Boolean, Boolean, int));
Boolean intern_p, allow_p;
long arity;
PRIMITIVE_HEADER (2);
CHECK_ARG (1, SYMBOL_P);
name = (ARG_REF (1));
TOUCH_IN_PRIMITIVE ((ARG_REF (2)), arity_arg);
if (arity_arg == SHARP_F)
{
allow_p = false;
intern_p = false;
arity = UNKNOWN_PRIMITIVE_ARITY;
}
else if (arity_arg == SHARP_T)
{
allow_p = true;
intern_p = false;
arity = UNKNOWN_PRIMITIVE_ARITY;
}
else
{
CHECK_ARG(2, FIXNUM_P);
allow_p = true;
intern_p = true;
arity = (FIXNUM_TO_LONG (arity_arg));
}
PRIMITIVE_RETURN
(find_primitive
((FAST_MEMORY_REF (name, SYMBOL_NAME)), intern_p, allow_p, arity));
}