From 0393f4d61804fa6c15cac2e6fc335ebc64fb50a9 Mon Sep 17 00:00:00 2001 From: jjgarcia Date: Sat, 28 Jul 2001 10:47:17 +0000 Subject: [PATCH] Implement accessor ROW-MAJOR-AREF. Implement special form COMPILER-LET. --- src/CHANGELOG | 4 +++- src/c/all_functions.d | 2 ++ src/c/array.d | 14 ++++++++++++++ src/c/compiler.d | 17 +++++++++++++++++ src/cmp/sysfun.lsp | 4 ++++ src/h/lisp_external.h | 2 ++ src/lsp/export.lsp | 2 ++ src/lsp/setf.lsp | 1 + 8 files changed, 45 insertions(+), 1 deletion(-) diff --git a/src/CHANGELOG b/src/CHANGELOG index 6a7fe9dab..6c532fe50 100644 --- a/src/CHANGELOG +++ b/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 diff --git a/src/c/all_functions.d b/src/c/all_functions.d index 7eef5d68e..cec246f3a 100644 --- a/src/c/all_functions.d +++ b/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}, diff --git a/src/c/array.d b/src/c/array.d index f3f2dc7d5..e785dd7f4 100644 --- a/src/c/array.d +++ b/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; diff --git a/src/c/compiler.d b/src/c/compiler.d index a751c0c34..0c4c2a8a8 100644 --- a/src/c/compiler.d +++ b/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 diff --git a/src/cmp/sysfun.lsp b/src/cmp/sysfun.lsp index fd6340824..e8755cd89 100644 --- a/src/cmp/sysfun.lsp +++ b/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) diff --git a/src/h/lisp_external.h b/src/h/lisp_external.h index f8ba03cda..0c9dd9b50 100644 --- a/src/h/lisp_external.h +++ b/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)); diff --git a/src/lsp/export.lsp b/src/lsp/export.lsp index 0f3d63f77..283e6eca5 100644 --- a/src/lsp/export.lsp +++ b/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 diff --git a/src/lsp/setf.lsp b/src/lsp/setf.lsp index a8e20dcab..1f3471621 100644 --- a/src/lsp/setf.lsp +++ b/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))