/* Build-in primitives, Define_Primitive
 */

#include "scheme.h"

struct Prim_Init {
    Object (*fun)();
    char *name;
    int minargs, maxargs;
    enum discipline disc;
} Primitives[] = {

    /* autoload.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_Greater,       "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_Greater,    "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,

    /* feature.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_Port_Line_Number,  "port-line-number",               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_Open_Input_Output_File, "open-input-output-file",    1, 1,    EVAL,
    P_Close_Input_Port,  "close-input-port",               1, 1,    EVAL,
    P_Close_Output_Port, "close-output-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_Caar,              "caar",                           1, 1,    EVAL,
    P_Cadr,              "cadr",                           1, 1,    EVAL,
    P_Cdar,              "cdar",                           1, 1,    EVAL,
    P_Cddr,              "cddr",                           1, 1,    EVAL,

    P_Caaar,             "caaar",                          1, 1,    EVAL,
    P_Caadr,             "caadr",                          1, 1,    EVAL,
    P_Cadar,             "cadar",                          1, 1,    EVAL,
    P_Caddr,             "caddr",                          1, 1,    EVAL,
    P_Cdaar,             "cdaar",                          1, 1,    EVAL,
    P_Cdadr,             "cdadr",                          1, 1,    EVAL,
    P_Cddar,             "cddar",                          1, 1,    EVAL,
    P_Cdddr,             "cdddr",                          1, 1,    EVAL,

    P_Caaaar,            "caaaar",                         1, 1,    EVAL,
    P_Caaadr,            "caaadr",                         1, 1,    EVAL,
    P_Caadar,            "caadar",                         1, 1,    EVAL,
    P_Caaddr,            "caaddr",                         1, 1,    EVAL,
    P_Cadaar,            "cadaar",                         1, 1,    EVAL,
    P_Cadadr,            "cadadr",                         1, 1,    EVAL,
    P_Caddar,            "caddar",                         1, 1,    EVAL,
    P_Cadddr,            "cadddr",                         1, 1,    EVAL,
    P_Cdaaar,            "cdaaar",                         1, 1,    EVAL,
    P_Cdaadr,            "cdaadr",                         1, 1,    EVAL,
    P_Cdadar,            "cdadar",                         1, 1,    EVAL,
    P_Cdaddr,            "cdaddr",                         1, 1,    EVAL,
    P_Cddaar,            "cddaar",                         1, 1,    EVAL,
    P_Cddadr,            "cddadr",                         1, 1,    EVAL,
    P_Cdddar,            "cdddar",                         1, 1,    EVAL,
    P_Cddddr,            "cddddr",                         1, 1,    EVAL,

    P_Cxr,               "cxr",                            2, 2,    EVAL,
    P_Nullp,             "null?",                          1, 1,    EVAL,
    P_Pairp,             "pair?",                          1, 1,    EVAL,
    P_Listp,             "list?",                          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,
    P_Exit,              "exit",                           0, 1,    VARARGS,

    /* math.c:
     */
    P_Number_To_String,  "number->string",                 1, 2,    VARARGS,
    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_Less,      "<",                              1, MANY, VARARGS,
    P_Generic_Greater,   ">",                              1, MANY, VARARGS,
    P_Generic_Equal,     "=",                              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_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_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_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,
    P_Peek_Char,         "peek-char",                      0, 1,    VARARGS,

    /* special.c:
     */
    P_Quote,             "quote",                          1, 1,    NOEVAL,
    P_Quasiquote,        "quasiquote",                     1, 1,    NOEVAL,
    P_Begin,             "begin",                          1, MANY, NOEVAL,
    P_Begin1,            "begin1",                         1, MANY, NOEVAL,
    P_If,                "if",                             2, MANY, NOEVAL,
    P_Case,              "case",                           2, 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, 2,    VARARGS,
    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_Greater,       "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_Greater,    "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);
}

/* Not used by the interpreter kernel (lint may complain).
 */
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;
}
