Implement accessor ROW-MAJOR-AREF.

Implement special form COMPILER-LET.

src/CHANGELOG

@@ -699,7 +699,7 @@ ECLS 0.3
     mangle named (clLunion in this case), that can be directly called
     from other translated files and from user written code.
 
-* Changes to user interface:
+* Visible changes and ANSI compatibility:
 
   - Remove variable si::*system-directory* and use logical hostname
     "SYS:" instead.
@@ -714,6 +714,8 @@ ECLS 0.3
     parameter. On top of this function, SI:EVAL-WITH-ENV, evaluates
     a form on a given environment.
 
+  - New accessor ROW-MAJOR-AREF.
+
 * System design and portability:
 
   - Code has been revised so that it works in environments where stack

src/c/all_functions.d

@@ -45,6 +45,8 @@ const struct function_info all_functions[] = {
 	{"ARRAY-TOTAL-SIZE", clLarray_total_size, cl},
 	{"ADJUSTABLE-ARRAY-P", clLadjustable_array_p, cl},
 	{"DISPLACED-ARRAY-P", siLdisplaced_array_p, si},
+	{"ROW-MAJOR-AREF", clLrow_major_aref, cl},
+	{"ROW-MAJOR-ASET", siLrow_major_aset, si},
 
 	{"SVREF", clLsvref, cl},
 	{"SVSET", siLsvset, si},

src/c/array.d

@@ -37,6 +37,20 @@ object_to_index(cl_object n)
 	}
 }
 
+@(defun row-major-aref (x indx)
+  cl_index j;
+@
+  j = fixnnint(indx);
+  @(return aref(x, j))
+@)
+
+@(defun si::row-major-aset (x indx val)
+  cl_index j;
+@
+  j = fixnnint(indx);
+  @(return aset(x, j, val))
+@)
+
 @(defun aref (x &rest indx)
   cl_index r, s, i, j;
   cl_object index;

src/c/compiler.d

@@ -57,6 +57,7 @@ static void c_and(cl_object args);
 static void c_block(cl_object args);
 static void c_case(cl_object args);
 static void c_catch(cl_object args);
+static void c_compiler_let(cl_object args);
 static void c_cond(cl_object args);
 static void c_do(cl_object args);
 static void c_doa(cl_object args);
@@ -299,6 +300,7 @@ static compiler_record database[] = {
   {OBJNULL, "BLOCK", c_block, 1},
   {OBJNULL, "CASE", c_case, 1},
   {OBJNULL, "CATCH", c_catch, 1},
+  {OBJNULL, "COMPILER-LET", c_compiler_let, 0},
   {OBJNULL, "COND", c_cond, 1},
   {OBJNULL, "DO", c_do, 1},
   {OBJNULL, "DO*", c_doa, 1},
@@ -576,6 +578,21 @@ c_catch(cl_object args) {
 	asm_complete(OP_CATCH, labelz);
 }
 
+static void
+c_compiler_let(cl_object args) {
+	cl_object bindings;
+	bds_ptr old_bds_top = bds_top;
+
+	for (bindings = pop(&args); !endp(bindings); ) {
+		cl_object form = pop(&bindings);
+		cl_object var = pop(&form);
+		cl_object value = pop_maybe_nil(&form);
+		bds_bind(var, value);
+	}
+	compile_body(args);
+	bds_unwind(old_bds_top);
+}
+
 /*
 	There are three operators which perform explicit jumps, but
 	almost all other operators use labels in one way or

src/cmp/sysfun.lsp

@@ -166,6 +166,10 @@
 		"(#1)->array.self.fix[#2]= #0")
 	:inline-unsafe ((fixnum (array bit) fixnum) fixnum t nil
 		"aset_bv(#1,#2,#0)"))
+(ROW-MAJOR-AREF (array fixnum) t
+	:inline-always ((array fixnum) t nil t "aref(#0,#1)"))
+(SI::ROW-MAJOR-ASET (array fixnum t) t
+	:inline-always ((array fixnum t) t nil t "aset(#0,#1,#2)"))
 (ARRAY-ELEMENT-TYPE (array) T)
 (ARRAY-RANK (array) fixnum)
 (ARRAY-DIMENSION (array fixnum) fixnum)

src/h/lisp_external.h

@@ -36,6 +36,8 @@ extern cl_object siLmangle_name _ARGS((int narg, cl_object symbol, ...));
 
 extern cl_object clLaref _ARGS((int narg, cl_object x, ...));
 extern cl_object siLaset _ARGS((int narg, cl_object v, cl_object x, ...));
+extern cl_object clLrow_major_aref _ARGS((int narg, cl_object x, cl_object i));
+extern cl_object siLrow_major_aset _ARGS((int narg, cl_object x, cl_object i, cl_object v));
 extern cl_object siLmake_pure_array _ARGS((int narg, cl_object etype, cl_object adj, cl_object displ, cl_object disploff, ...));
 extern cl_object siLmake_vector _ARGS((int narg, cl_object etype, cl_object dim, cl_object adj, cl_object fillp, cl_object displ, cl_object disploff));
 extern cl_object clLarray_element_type _ARGS((int narg, cl_object a));

src/lsp/export.lsp

@@ -66,6 +66,7 @@
 	  bit-orc1
 	  bit-orc2
 	  bit-xor
+	  boolean
 	  break
 	  byte
 	  byte-position
@@ -227,6 +228,7 @@
 	  replace
 	  require
 	  rotatef
+	  row-major-aref
 	  room
 	  sbit
 	  search

src/lsp/setf.lsp

@@ -185,6 +185,7 @@
 (defsetf symbol-function sys:fset)
 (defsetf macro-function (s) (v) `(sys:fset ,s ,v t))
 (defsetf aref (a &rest il) (v) `(sys:aset ,v ,a ,@il))
+(defsetf row-major-aref (a i) (v) `(sys:row-major-aset ,v ,i ,a))
 (defsetf get (s p &optional d) (v)
   (if d `(progn ,d (sys:putprop ,s ,v ,p)) `(sys:putprop ,s ,v ,p)))
 (defsetf nth (n l) (v) `(progn (rplaca (nthcdr ,n ,l) ,v) ,v))