/* Table of primitives */ #include "scheme.h" struct Prim_Init { Object (*fun)(); char *name; int minargs, maxargs; enum discipline disc; } Primitives[] = { /* auto.c: */ P_Autoload, "autoload", 2, 2, EVAL, /* bool.c: */ P_Booleanp, "boolean?", 1, 1, EVAL, P_Not, "not", 1, 1, EVAL, P_Eq, "eq?", 2, 2, EVAL, P_Eqv, "eqv?", 2, 2, EVAL, P_Equal, "equal?", 2, 2, EVAL, /* char.c: */ P_Charp, "char?", 1, 1, EVAL, P_Char_To_Integer, "char->integer", 1, 1, EVAL, P_Integer_To_Char, "integer->char", 1, 1, EVAL, P_Char_Upper_Case, "char-upper-case?", 1, 1, EVAL, P_Char_Lower_Case, "char-lower-case?", 1, 1, EVAL, P_Char_Alphabetic, "char-alphabetic?", 1, 1, EVAL, P_Char_Numeric, "char-numeric?", 1, 1, EVAL, P_Char_Whitespace, "char-whitespace?", 1, 1, EVAL, P_Char_Upcase, "char-upcase", 1, 1, EVAL, P_Char_Downcase, "char-downcase", 1, 1, EVAL, P_Chr_Eq, "char=?", 2, 2, EVAL, P_Chr_Less, "char?", 2, 2, EVAL, P_Chr_Eq_Less, "char<=?", 2, 2, EVAL, P_Chr_Eq_Greater, "char>=?", 2, 2, EVAL, P_Chr_CI_Eq, "char-ci=?", 2, 2, EVAL, P_Chr_CI_Less, "char-ci?", 2, 2, EVAL, P_Chr_CI_Eq_Less, "char-ci<=?", 2, 2, EVAL, P_Chr_CI_Eq_Greater, "char-ci>=?", 2, 2, EVAL, /* cont.c: */ P_Control_Pointp, "control-point?", 1, 1, EVAL, P_Call_CC, "call-with-current-continuation", 1, 1, EVAL, P_Dynamic_Wind, "dynamic-wind", 3, 3, EVAL, P_Control_Point_Env, "control-point-environment", 1, 1, EVAL, /* debug.c: */ P_Backtrace_List, "backtrace-list", 0, 1, VARARGS, /* dump.c: */ #ifdef CAN_DUMP P_Dump, "dump", 1, 1, EVAL, #endif /* env.c: */ P_Environmentp, "environment?", 1, 1, EVAL, P_The_Environment, "the-environment", 0, 0, EVAL, P_Global_Environment,"global-environment", 0, 0, EVAL, P_Define, "define", 1, MANY, NOEVAL, P_Define_Macro, "define-macro", 1, MANY, NOEVAL, P_Set, "set!", 2, 2, NOEVAL, P_Env_List, "environment->list", 1, 1, EVAL, P_Boundp, "bound?", 1, 1, EVAL, /* error.c: */ P_Error, "error", 2, MANY, VARARGS, P_Reset, "reset", 0, 0, EVAL, /* features.c: */ P_Featurep, "feature?", 1, 1, EVAL, P_Provide, "provide", 1, 1, EVAL, P_Require, "require", 1, 3, VARARGS, /* heap.c: */ P_Collect, "collect", 0, 0, EVAL, /* io.c: */ P_Port_File_Name, "port-file-name", 1, 1, EVAL, P_Eof_Objectp, "eof-object?", 1, 1, EVAL, P_Curr_Input_Port, "current-input-port", 0, 0, EVAL, P_Curr_Output_Port, "current-output-port", 0, 0, EVAL, P_Input_Portp, "input-port?", 1, 1, EVAL, P_Output_Portp, "output-port?", 1, 1, EVAL, P_Open_Input_File, "open-input-file", 1, 1, EVAL, P_Open_Output_File, "open-output-file", 1, 1, EVAL, P_Close_Port, "close-port", 1, 1, EVAL, P_With_Input, "with-input-from-file", 2, 2, EVAL, P_With_Output, "with-output-to-file", 2, 2, EVAL, P_Call_With_Input, "call-with-input-file", 2, 2, EVAL, P_Call_With_Output, "call-with-output-file", 2, 2, EVAL, P_Open_Input_String, "open-input-string", 1, 1, EVAL, P_Open_Output_String,"open-output-string", 0, 0, EVAL, P_Tilde_Expand, "tilde-expand", 1, 1, EVAL, P_File_Existsp, "file-exists?", 1, 1, EVAL, /* load.c: */ P_Load, "load", 1, 2, VARARGS, /* list.c: */ P_Cons, "cons", 2, 2, EVAL, P_Car, "car", 1, 1, EVAL, P_Cdr, "cdr", 1, 1, EVAL, P_Cddr, "cddr", 1, 1, EVAL, P_Cdar, "cdar", 1, 1, EVAL, P_Cadr, "cadr", 1, 1, EVAL, P_Caar, "caar", 1, 1, EVAL, P_Cdddr, "cdddr", 1, 1, EVAL, P_Cddar, "cddar", 1, 1, EVAL, P_Cdadr, "cdadr", 1, 1, EVAL, P_Cdaar, "cdaar", 1, 1, EVAL, P_Caddr, "caddr", 1, 1, EVAL, P_Cadar, "cadar", 1, 1, EVAL, P_Caadr, "caadr", 1, 1, EVAL, P_Caaar, "caaar", 1, 1, EVAL, P_Cxr, "cxr", 2, 2, EVAL, P_Nullp, "null?", 1, 1, EVAL, P_Pairp, "pair?", 1, 1, EVAL, P_Setcar, "set-car!", 2, 2, EVAL, P_Setcdr, "set-cdr!", 2, 2, EVAL, P_Assq, "assq", 2, 2, EVAL, P_Assv, "assv", 2, 2, EVAL, P_Assoc, "assoc", 2, 2, EVAL, P_Memq, "memq", 2, 2, EVAL, P_Memv, "memv", 2, 2, EVAL, P_Member, "member", 2, 2, EVAL, P_Make_List, "make-list", 2, 2, EVAL, P_List, "list", 0, MANY, VARARGS, P_Length, "length", 1, 1, EVAL, P_Append, "append", 0, MANY, VARARGS, P_Append_Set, "append!", 0, MANY, VARARGS, P_Last_Pair, "last-pair", 1, 1, EVAL, P_Reverse, "reverse", 1, 1, EVAL, P_Reverse_Set, "reverse!", 1, 1, EVAL, P_List_Tail, "list-tail", 2, 2, EVAL, P_List_Ref, "list-ref", 2, 2, EVAL, /* main.c: */ P_Command_Line_Args, "command-line-args", 0, 0, EVAL, /* math.c: */ P_Numberp, "number?", 1, 1, EVAL, P_Complexp, "complex?", 1, 1, EVAL, P_Realp, "real?", 1, 1, EVAL, P_Rationalp, "rational?", 1, 1, EVAL, P_Integerp, "integer?", 1, 1, EVAL, P_Zerop, "zero?", 1, 1, EVAL, P_Positivep, "positive?", 1, 1, EVAL, P_Negativep, "negative?", 1, 1, EVAL, P_Oddp, "odd?", 1, 1, EVAL, P_Evenp, "even?", 1, 1, EVAL, P_Exactp, "exact?", 1, 1, EVAL, P_Inexactp, "inexact?", 1, 1, EVAL, P_Generic_Equal, "=", 1, MANY, VARARGS, P_Generic_Less, "<", 1, MANY, VARARGS, P_Generic_Greater, ">", 1, MANY, VARARGS, P_Generic_Eq_Less, "<=", 1, MANY, VARARGS, P_Generic_Eq_Greater,">=", 1, MANY, VARARGS, P_Inc, "1+", 1, 1, EVAL, P_Dec, "1-", 1, 1, EVAL, P_Generic_Plus, "+", 0, MANY, VARARGS, P_Generic_Minus, "-", 1, MANY, VARARGS, P_Generic_Multiply, "*", 0, MANY, VARARGS, P_Generic_Divide, "/", 1, MANY, VARARGS, P_Abs, "abs", 1, 1, EVAL, P_Quotient, "quotient", 2, 2, EVAL, P_Remainder, "remainder", 2, 2, EVAL, P_Modulo, "modulo", 2, 2, EVAL, P_Gcd, "gcd", 0, MANY, VARARGS, P_Lcm, "lcm", 0, MANY, VARARGS, P_Floor, "floor", 1, 1, EVAL, P_Ceiling, "ceiling", 1, 1, EVAL, P_Truncate, "truncate", 1, 1, EVAL, P_Round, "round", 1, 1, EVAL, P_Sqrt, "sqrt", 1, 1, EVAL, P_Exp, "exp", 1, 1, EVAL, P_Log, "log", 1, 1, EVAL, P_Sin, "sin", 1, 1, EVAL, P_Cos, "cos", 1, 1, EVAL, P_Tan, "tan", 1, 1, EVAL, P_Asin, "asin", 1, 1, EVAL, P_Acos, "acos", 1, 1, EVAL, P_Atan, "atan", 1, 2, VARARGS, P_Min, "min", 1, MANY, VARARGS, P_Max, "max", 1, MANY, VARARGS, P_Random, "random", 0, 0, EVAL, P_Srandom, "srandom", 1, 1, EVAL, /* prim.c: */ /* print.c: */ P_Write, "write", 1, 2, VARARGS, P_Display, "display", 1, 2, VARARGS, P_Write_Char, "write-char", 1, 2, VARARGS, P_Newline, "newline", 0, 1, VARARGS, P_Print, "print", 1, 2, VARARGS, P_Clear_Output_Port, "clear-output-port", 0, 1, VARARGS, P_Flush_Output_Port, "flush-output-port", 0, 1, VARARGS, P_Get_Output_String, "get-output-string", 1, 1, EVAL, P_Format, "format", 2, MANY, VARARGS, /* proc.c: */ P_Procedurep, "procedure?", 1, 1, EVAL, P_Primitivep, "primitive?", 1, 1, EVAL, P_Compoundp, "compound?", 1, 1, EVAL, P_Macrop, "macro?", 1, 1, EVAL, P_Eval, "eval", 1, 2, VARARGS, P_Apply, "apply", 2, MANY, VARARGS, P_Lambda, "lambda", 2, MANY, NOEVAL, P_Procedure_Env, "procedure-environment", 1, 1, EVAL, P_Procedure_Lambda, "procedure-lambda", 1, 1, EVAL, P_Begin, "begin", 1, MANY, NOEVAL, P_Begin1, "begin1", 1, MANY, NOEVAL, P_Map, "map", 2, MANY, VARARGS, P_For_Each, "for-each", 2, MANY, VARARGS, P_Macro, "macro", 2, MANY, NOEVAL, P_Macro_Body, "macro-body", 1, 1, EVAL, P_Macro_Expand, "macro-expand", 1, 1, EVAL, /* promise.c: */ P_Delay, "delay", 1, 1, NOEVAL, P_Force, "force", 1, 1, EVAL, P_Promisep, "promise?", 1, 1, EVAL, P_Promise_Env, "promise-environment", 1, 1, EVAL, /* read.c: */ P_Exit, "exit", 0, 1, VARARGS, P_Clear_Input_Port, "clear-input-port", 0, 1, EVAL, P_Read, "read", 0, 1, VARARGS, P_Read_Char, "read-char", 0, 1, VARARGS, P_Read_String, "read-string", 0, 1, VARARGS, P_Unread_Char, "unread-char", 1, 2, VARARGS, /* special.c: */ P_Quote, "quote", 1, 1, NOEVAL, P_Quasiquote, "quasiquote", 1, 1, NOEVAL, P_If, "if", 2, MANY, NOEVAL, P_Case, "case", 1, MANY, NOEVAL, P_Cond, "cond", 1, MANY, NOEVAL, P_Do, "do", 2, MANY, NOEVAL, P_Let, "let", 2, MANY, NOEVAL, P_Letseq, "let*", 2, MANY, NOEVAL, P_Letrec, "letrec", 2, MANY, NOEVAL, P_Fluid_Let, "fluid-let", 2, MANY, NOEVAL, P_And, "and", 0, MANY, NOEVAL, P_Or, "or", 0, MANY, NOEVAL, /* string.c: */ P_String, "string", 0, MANY, VARARGS, P_Stringp, "string?", 1, 1, EVAL, P_Make_String, "make-string", 1, 2, VARARGS, P_String_Length, "string-length", 1, 1, EVAL, P_String_To_Number, "string->number", 1, 1, EVAL, P_String_Ref, "string-ref", 2, 2, EVAL, P_String_Set, "string-set!", 3, 3, EVAL, P_Substring, "substring", 3, 3, EVAL, P_String_Copy, "string-copy", 1, 1, EVAL, P_String_Append, "string-append", 0, MANY, VARARGS, P_List_To_String, "list->string", 1, 1, EVAL, P_String_To_List, "string->list", 1, 1, EVAL, P_String_Fill, "string-fill!", 2, 2, EVAL, P_Substring_Fill, "substring-fill!", 4, 4, EVAL, P_Str_Eq, "string=?", 2, 2, EVAL, P_Str_Less, "string?", 2, 2, EVAL, P_Str_Eq_Less, "string<=?", 2, 2, EVAL, P_Str_Eq_Greater, "string>=?", 2, 2, EVAL, P_Str_CI_Eq, "string-ci=?", 2, 2, EVAL, P_Str_CI_Less, "string-ci?", 2, 2, EVAL, P_Str_CI_Eq_Less, "string-ci<=?", 2, 2, EVAL, P_Str_CI_Eq_Greater, "string-ci>=?", 2, 2, EVAL, P_Substringp, "substring?", 2, 2, EVAL, P_CI_Substringp, "substring-ci?", 2, 2, EVAL, /* symbol.c: */ P_String_To_Symbol, "string->symbol", 1, 1, EVAL, P_Oblist, "oblist", 0, 0, EVAL, P_Symbolp, "symbol?", 1, 1, EVAL, P_Symbol_To_String, "symbol->string", 1, 1, EVAL, P_Put, "put", 2, 3, VARARGS, P_Get, "get", 2, 2, EVAL, P_Symbol_Plist, "symbol-plist", 1, 1, EVAL, /* type.c: */ P_Type, "type", 1, 1, EVAL, P_Voidp, "void?", 1, 1, EVAL, /* vector.c: */ P_Vectorp, "vector?", 1, 1, EVAL, P_Make_Vector, "make-vector", 1, 2, VARARGS, P_Vector, "vector", 0, MANY, VARARGS, P_Vector_Length, "vector-length", 1, 1, EVAL, P_Vector_Ref, "vector-ref", 2, 2, EVAL, P_Vector_Set, "vector-set!", 3, 3, EVAL, P_Vector_To_List, "vector->list", 1, 1, EVAL, P_List_To_Vector, "list->vector", 1, 1, EVAL, P_Vector_Fill, "vector-fill!", 2, 2, EVAL, P_Vector_Copy, "vector-copy", 1, 1, EVAL, 0 }; /* The C-compiler can't initialize unions, thus the primitive procedures * must be created during run-time (the problem actually is that one can't * provide an intializer for the "tag" component of an S_Primitive). */ Init_Prim () { register struct Prim_Init *p; Object frame, prim, sym; for (frame = Car (The_Environment), p = Primitives; p->fun; p++) { prim = Make_Primitive (p->fun, p->name, p->minargs, p->maxargs, p->disc); sym = Intern (p->name); frame = Add_Binding (frame, sym, prim); } Car (The_Environment) = frame; Memoize_Frame (frame); } Define_Primitive (fun, name, min, max, disc) Object (*fun)(); char *name; enum discipline disc; { Object prim, sym, frame; GC_Node2; Error_Tag = "define-primitive"; prim = Make_Primitive (fun, name, min, max, disc); sym = Null; GC_Link2 (prim, sym); sym = Intern (name); if (disc == EVAL && min != max) Primitive_Error ("~s: number of arguments must be fixed", sym); frame = Add_Binding (Car (The_Environment), sym, prim); SYMBOL(sym)->value = prim; Car (The_Environment) = frame; GC_Unlink; }