From: Chris Hanson Date: Sun, 11 Feb 2018 01:37:08 +0000 (-0800) Subject: Rewrite this file to match current standards. X-Git-Tag: mit-scheme-pucked-x11-0.3.1~7^2~260 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=e35a14fd93070cc8164e51d06eee7f18edb1f637;p=mit-scheme.git Rewrite this file to match current standards. --- diff --git a/src/microcode/list.c b/src/microcode/list.c index 99424b1b4..f56603a15 100644 --- a/src/microcode/list.c +++ b/src/microcode/list.c @@ -29,20 +29,16 @@ USA. #include "scheme.h" #include "prims.h" -DEFINE_PRIMITIVE ("PAIR?", Prim_pair, 1, 1, - "(object)\n\ - Returns #t if object is a pair; otherwise returns #f.\ -") +DEFINE_PRIMITIVE ("pair?", Prim_pair, 1, 1, + "(OBJECT)\n\ +Returns #t iff OBJECT is a pair") { - SCHEME_OBJECT object; PRIMITIVE_HEADER (1); - object = (ARG_REF (1)); - PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (PAIR_P (object))); + PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (PAIR_P (ARG_REF (1)))); } SCHEME_OBJECT -cons (SCHEME_OBJECT car, - SCHEME_OBJECT cdr) +cons (SCHEME_OBJECT car, SCHEME_OBJECT cdr) { Primitive_GC_If_Needed (2); (*Free++) = car; @@ -50,129 +46,99 @@ cons (SCHEME_OBJECT car, return (MAKE_POINTER_OBJECT (TC_LIST, (Free - 2))); } -DEFINE_PRIMITIVE ("CONS", Prim_cons, 2, 2, - "(obj1 obj2)\n\ - Returns a newly allocated pair whose car is OBJ1 and whose cdr is OBJ2.\n\ - The pair is guaranteed to be different (in the sense of EQV?) from other\n\ - previously existing object.\ - ") +DEFINE_PRIMITIVE ("cons", Prim_cons, 2, 2, +"(OBJ1 OBJ2)\n\ +Returns a newly allocated pair whose car is OBJ1 and whose cdr is OBJ2.") { PRIMITIVE_HEADER (2); PRIMITIVE_RETURN (cons ((ARG_REF (1)), (ARG_REF (2)))); } -DEFINE_PRIMITIVE ("CAR", Prim_car, 1, 1, - "(pair)\n\ - Returns the contents of the car field of PAIR.\n\ - Note that it is an error to take the CAR of an empty list.\ - ") +DEFINE_PRIMITIVE ("car", Prim_car, 1, 1, +"(PAIR)\n\ +Returns the contents of the car field of PAIR.") { PRIMITIVE_HEADER (1); CHECK_ARG (1, PAIR_P); PRIMITIVE_RETURN (PAIR_CAR (ARG_REF (1))); } -DEFINE_PRIMITIVE ("CDR", Prim_cdr, 1, 1, - "(pair)\n\ - Returns the contents of the cdr field of PAIR.\n\ - Note that it is an error to take the CDR of an empty list.\ - ") +DEFINE_PRIMITIVE ("cdr", Prim_cdr, 1, 1, +"(PAIR)\n\ +Returns the contents of the cdr field of PAIR") { PRIMITIVE_HEADER (1); CHECK_ARG (1, PAIR_P); PRIMITIVE_RETURN (PAIR_CDR (ARG_REF (1))); } -DEFINE_PRIMITIVE ("SET-CAR!", Prim_set_car, 2, 2, - "(pair object)\n\ - Store OBJECT in the car field of PAIR.\n\ - The value returned by SET-CAR! is unspecified.\ - ") +DEFINE_PRIMITIVE ("set-car!", Prim_set_car, 2, 2, + "(PAIR OBJECT)\n\ +Stores OBJECT in the car field of PAIR and returns an unspecified value.") { PRIMITIVE_HEADER (2); CHECK_ARG (1, PAIR_P); - { - SCHEME_OBJECT pair = (ARG_REF (1)); - SCHEME_OBJECT car = (ARG_REF (2)); - SET_PAIR_CAR (pair, car); - } + SET_PAIR_CAR ((ARG_REF (1)), (ARG_REF (2))); PRIMITIVE_RETURN (UNSPECIFIC); } -DEFINE_PRIMITIVE ("SET-CDR!", Prim_set_cdr, 2, 2, - "(pair object)\n\ - Store OBJECT in the cdr field of PAIR.\n\ - The value returned by SET-CDR! is unspecified.\ - ") +DEFINE_PRIMITIVE ("set-cdr!", Prim_set_cdr, 2, 2, +"(PAIR OBJECT)\n\ +Stores OBJECT in the cdr field of PAIR and returns an unspecified value.") { PRIMITIVE_HEADER (2); CHECK_ARG (1, PAIR_P); - { - SCHEME_OBJECT pair = (ARG_REF (1)); - SCHEME_OBJECT cdr = (ARG_REF (2)); - SET_PAIR_CDR (pair, cdr); - } + SET_PAIR_CDR ((ARG_REF (1)), (ARG_REF (2))); PRIMITIVE_RETURN (UNSPECIFIC); } -/* (GENERAL-CAR-CDR LIST DIRECTIONS) - DIRECTIONS encodes a string of CAR and CDR operations to be - performed on LIST as follows: - 1 = NOP 101 = CDAR - 10 = CDR 110 = CADR - 11 = CAR 111 = CAAR - 100 = CDDR ... */ - -DEFINE_PRIMITIVE ("GENERAL-CAR-CDR", Prim_general_car_cdr, 2, 2, - "(object path)\n\ - This procedure is a generalization of `car' and `cdr'. PATH\n\ - encodes a particular sequence of `car' and `cdr' operations, which\n\ - `general-car-cdr' executes on OBJECT. PATH is an exact\n\ - non-negative integer that encodes the operations in a bitwise\n\ - fashion: a zero bit represents a `cdr' operation, and a one bit\n\ - represents a `car'. The bits are executed LSB to MSB, and the\n\ - most significant one bit, rather than being interpreted as an\n\ - operation, signals the end of the sequence.\n\ - \n\ - For example, the following are equivalent:\n\ - (general-car-cdr OBJECT #b1011)\n\ - (cdr (car (car OBJECT)))\n\ - \n\ - Here is a partial table of path/operation equivalents:\n\ - \n\ - #b10 cdr\n\ - #b11 car\n\ - #b100 cddr\n\ - #b101 cdar\n\ - #b110 cadr\n\ - #b111 caar\n\ - #b1000 cdddr\n\ - \n\ - Note that PATH is restricted to a machine-dependent range,\n\ - usually the size of a machine word. On many machines, this means that\n\ - the maximum length of PATH will be 30 operations (32 bits, less the\n\ - sign bit and the "end-of-sequence" bit).\ - ") +DEFINE_PRIMITIVE ("general-car-cdr", Prim_general_car_cdr, 2, 2, +"(OBJECT PATH)\n\ +\n\ +This procedure is a generalization of CAR and CDR. PATH encodes a\n\ +particular sequence of CAR and CDR operations, which this procedure\n\ +executes on OBJECT.\n\ +\n\ +PATH is an exact non-negative integer that encodes the operations in a\n\ +bitwise fashion: a zero bit represents a CDR operation, and a one bit\n\ +represents a CAR. The bits are executed LSB to MSB, and the most\n\ +significant one bit, rather than being interpreted as an operation,\n\ +signals the end of the sequence.\n\ +\n\ +For example, the following are equivalent:\n\ +\n\ + (general-car-cdr OBJECT #b1011)\n\ + (cdr (car (car OBJECT)))\n\ +\n\ +Here is a partial table of path/operation equivalents:\n\ +\n\ + #b10 cdr\n\ + #b11 car\n\ + #b100 cddr\n\ + #b101 cdar\n\ + #b110 cadr\n\ + #b111 caar\n\ + #b1000 cdddr\n\ +\n\ +Note that this implementation restricts PATH to the length of the\n\ +machine word. Since one bit is used as a limit marker, this means the\n\ +maximum length is 31 bits for a 32-bit architecture, and 63 bits for a\n\ +64-bit architecture.") { PRIMITIVE_HEADER (2); - { - SCHEME_OBJECT object = (ARG_REF (1)); - long CAR_CDR_Pattern = (arg_nonnegative_integer (2)); - while (CAR_CDR_Pattern > 1) - { - if (! (PAIR_P (object))) - error_wrong_type_arg (1); - object = - (((CAR_CDR_Pattern & 1) == 0) - ? (PAIR_CDR (object)) - : (PAIR_CAR (object))); - CAR_CDR_Pattern >>= 1; - } - PRIMITIVE_RETURN (object); - } + SCHEME_OBJECT object = (ARG_REF (1)); + unsigned long path = (arg_ulong_integer (2)); + while (path > 1) + { + if (!PAIR_P (object)) + error_wrong_type_arg (1); + object = (((path & 1) == 0) ? (PAIR_CDR (object)) : (PAIR_CAR (object))); + path >>= 1; + } + PRIMITIVE_RETURN (object); } -DEFINE_PRIMITIVE ("SYSTEM-PAIR?", Prim_sys_pair, 1, 1, 0) +DEFINE_PRIMITIVE ("system-pair?", Prim_sys_pair, 1, 1, 0) { SCHEME_OBJECT object; PRIMITIVE_HEADER (1); @@ -181,9 +147,7 @@ DEFINE_PRIMITIVE ("SYSTEM-PAIR?", Prim_sys_pair, 1, 1, 0) } SCHEME_OBJECT -system_pair_cons (long type, - SCHEME_OBJECT car, - SCHEME_OBJECT cdr) +system_pair_cons (long type, SCHEME_OBJECT car, SCHEME_OBJECT cdr) { Primitive_GC_If_Needed (2); (*Free++) = car; @@ -191,52 +155,42 @@ system_pair_cons (long type, return (MAKE_POINTER_OBJECT (type, (Free - 2))); } -DEFINE_PRIMITIVE ("SYSTEM-PAIR-CONS", Prim_sys_pair_cons, 3, 3, 0) +DEFINE_PRIMITIVE ("system-pair-cons", Prim_sys_pair_cons, 3, 3, 0) { PRIMITIVE_HEADER (3); - { - unsigned long type = (arg_ulong_index_integer (1, N_TYPE_CODES)); - if ((GC_TYPE_CODE (type)) != GC_PAIR) - error_bad_range_arg (1); - PRIMITIVE_RETURN (system_pair_cons (type, (ARG_REF (2)), (ARG_REF (3)))); - } + unsigned long type = (arg_ulong_index_integer (1, N_TYPE_CODES)); + if ((GC_TYPE_CODE (type)) != GC_PAIR) + error_bad_range_arg (1); + PRIMITIVE_RETURN (system_pair_cons (type, (ARG_REF (2)), (ARG_REF (3)))); } -DEFINE_PRIMITIVE ("SYSTEM-PAIR-CAR", Prim_sys_pair_car, 1, 1, 0) +DEFINE_PRIMITIVE ("system-pair-car", Prim_sys_pair_car, 1, 1, 0) { PRIMITIVE_HEADER (1); CHECK_ARG (1, GC_TYPE_PAIR); PRIMITIVE_RETURN (PAIR_CAR (ARG_REF (1))); } -DEFINE_PRIMITIVE ("SYSTEM-PAIR-CDR", Prim_sys_pair_cdr, 1, 1, 0) +DEFINE_PRIMITIVE ("system-pair-cdr", Prim_sys_pair_cdr, 1, 1, 0) { PRIMITIVE_HEADER (1); CHECK_ARG (1, GC_TYPE_PAIR); PRIMITIVE_RETURN (PAIR_CDR (ARG_REF (1))); } -DEFINE_PRIMITIVE ("SYSTEM-PAIR-SET-CAR!", Prim_sys_set_car, 2, 2, 0) +DEFINE_PRIMITIVE ("system-pair-set-car!", Prim_sys_set_car, 2, 2, 0) { PRIMITIVE_HEADER (2); CHECK_ARG (1, GC_TYPE_PAIR); - { - SCHEME_OBJECT pair = (ARG_REF (1)); - SCHEME_OBJECT car = (ARG_REF (2)); - SET_PAIR_CAR (pair, car); - } + SET_PAIR_CAR ((ARG_REF (1)), (ARG_REF (2))); PRIMITIVE_RETURN (UNSPECIFIC); } -DEFINE_PRIMITIVE ("SYSTEM-PAIR-SET-CDR!", Prim_sys_set_cdr, 2, 2, 0) +DEFINE_PRIMITIVE ("system-pair-set-cdr!", Prim_sys_set_cdr, 2, 2, 0) { PRIMITIVE_HEADER (2); CHECK_ARG (1, GC_TYPE_PAIR); - { - SCHEME_OBJECT pair = (ARG_REF (1)); - SCHEME_OBJECT cdr = (ARG_REF (2)); - SET_PAIR_CDR (pair, cdr); - } + SET_PAIR_CDR ((ARG_REF (1)), (ARG_REF (2))); PRIMITIVE_RETURN (UNSPECIFIC); }