Added support for R7RS. New primitives: make-list, string-map,...

Added support for R7RS. New primitives: make-list, string-map, string-for-each, vector-for-each, vector-map

lib/Makefile.am

@@ -2,7 +2,7 @@
 #
 #           Author: Erick Gallesio [eg@unice.fr]
 #    Creation date: 11-Apr-2000 10:30 (eg)
-# Last file update: 23-Oct-2010 11:56 (eg)
+# Last file update: 17-Apr-2011 21:33 (eg)
 
 SUBDIRS = Match.d SILex.d Lalr.d ScmPkg.d
 
@@ -27,6 +27,7 @@ scheme_BOOT = assembler.stk		\
 	      peephole.stk		\
 	      process.stk		\
 	      r5rs.stk 			\
+	      r7rs.stk			\
 	      regexp.stk		\
 	      readline.stk		\
 	      repl.stk 			\
@@ -123,7 +124,7 @@ scheme_OBJS = compfile.ostk		\
 	      srfi-96.ostk		\
 	      srfi-100.ostk		\
 	      tar.ostk			\
-	      trace.ostk	
+	      trace.ostk
 
 DOCDB	    = DOCDB
 
@@ -144,9 +145,9 @@ SUFFIXES = .stk .ostk .scm
 
 all-recursive: boot compfile.ostk
 
-boot:	../src/boot.img 
+boot:	../src/boot.img
 
-../src/boot.img: $(scheme_BOOT) 
+../src/boot.img: $(scheme_BOOT)
 	@echo "*** Boot 0"; \
 	(export STKLOS_BUILDING=1; \
 	../src/stklos -q -c -b ../src/boot.img -f bb.stk boot.img0 instr0)
@@ -179,7 +180,7 @@ boot:	../src/boot.img
 
 # Compile SRFI13 before SRFI14 to avoid 2 warnings
 
-$(SCHEME_OBJS): ../src/boot.img 
+$(SCHEME_OBJS): ../src/boot.img
 compfile.ostk: getopt.ostk
 ffi.ostk: bigmatch.ostk
 full-conditions: srfi-35.ostk srfi-36.stk

lib/Makefile.in

@@ -19,7 +19,7 @@
 #
 #           Author: Erick Gallesio [eg@unice.fr]
 #    Creation date: 11-Apr-2000 10:30 (eg)
-# Last file update: 23-Oct-2010 11:56 (eg)
+# Last file update: 17-Apr-2011 21:33 (eg)
 
 VPATH = @srcdir@
 pkgdatadir = $(datadir)/@PACKAGE@
@@ -270,6 +270,7 @@ scheme_BOOT = assembler.stk		\
 	      peephole.stk		\
 	      process.stk		\
 	      r5rs.stk 			\
+	      r7rs.stk			\
 	      regexp.stk		\
 	      readline.stk		\
 	      repl.stk 			\
@@ -365,7 +366,7 @@ scheme_OBJS = compfile.ostk		\
 	      srfi-96.ostk		\
 	      srfi-100.ostk		\
 	      tar.ostk			\
-	      trace.ostk	
+	      trace.ostk
 
 DOCDB = DOCDB
 
@@ -745,9 +746,9 @@ uninstall-am: uninstall-schemeDATA
 
 all-recursive: boot compfile.ostk
 
-boot:	../src/boot.img 
+boot:	../src/boot.img
 
-../src/boot.img: $(scheme_BOOT) 
+../src/boot.img: $(scheme_BOOT)
 	@echo "*** Boot 0"; \
 	(export STKLOS_BUILDING=1; \
 	../src/stklos -q -c -b ../src/boot.img -f bb.stk boot.img0 instr0)
@@ -780,7 +781,7 @@ boot:	../src/boot.img
 
 # Compile SRFI13 before SRFI14 to avoid 2 warnings
 
-$(SCHEME_OBJS): ../src/boot.img 
+$(SCHEME_OBJS): ../src/boot.img
 compfile.ostk: getopt.ostk
 ffi.ostk: bigmatch.ostk
 full-conditions: srfi-35.ostk srfi-36.stk

lib/boot.stk

 ;;;;
 ;;;; boot.stk					-- Default boot file
-;;;; 
-;;;; Copyright  2000-2010 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
-;;;; 
-;;;; 
+;;;;
+;;;; Copyright  2000-2011 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
+;;;;
+;;;;
 ;;;; This program is free software; you can redistribute it and/or modify
 ;;;; it under the terms of the GNU General Public License as published by
 ;;;; the Free Software Foundation; either version 2 of the License, or
 ;;;; (at your option) any later version.
-;;;; 
+;;;;
 ;;;; This program is distributed in the hope that it will be useful,
 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 ;;;; GNU General Public License for more details.
-;;;; 
+;;;;
 ;;;; You should have received a copy of the GNU General Public License
 ;;;; along with this program; if not, write to the Free Software
-;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, 
+;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
 ;;;; USA.
-;;;; 
+;;;;
 ;;;;           Author: Erick Gallesio [eg@unice.fr]
 ;;;;    Creation date: 01-Jan-2000 15:04 (eg)
-;;;; Last file update: 16-Oct-2010 15:56 (eg)
+;;;; Last file update: 17-Apr-2011 21:05 (eg)
 ;;;;
 
 (include "runtime.stk")		; Definition necessary for the bootstrap
@@ -32,7 +32,7 @@
 (include "bonus.stk")		; Extended functions and syntaxes
 (include "load.stk")		; Extended load dealing with paths and suffixes
 (include "srfi-0.stk")		; Implementation of SRFI-0
-(include "mbe.stk")		; A simple R5RS macro system 
+(include "mbe.stk")		; A simple R5RS macro system
 (include "regexp.stk")		; Regular expressions
 (include "process.stk")		; Processes from Scheme
 (include "compiler.stk")	; VM Compiler
@@ -41,6 +41,7 @@
 (include "logical.stk")		; Logical operations
 (include "thread.stk")		; Thread support
 (include "ffi.stk")		; FFI support
+(include "r7rs.stk")		; Preliminary support of R7RS
 (include "obsolete.stk")	; Obsolete functions. Candidates to disappear
 (include "repl.stk")		; Read Eval Print Loop
 (include "readline.stk")	; Readline support
@@ -96,7 +97,7 @@
 	   (cons "  - ...\nSet shell variable STKLOS_FRAMES to set visible frames\n"
 		 (list-tail (reverse! bt) (- len depth))))
 	  bt)))
-  
+
   (let ((p (current-error-port)))
     (for-each (lambda (x)
 		(if (string? x)
@@ -148,7 +149,7 @@
 (define (%simple-fatal-exception-handler what who c useless-frames)
   (let ((port (current-error-port))
 	(bt   #f))
-    ;; Display the message 
+    ;; Display the message
     (format port "**** Error while ~A ~S\n" what who)
     (when (condition? c)
       (when (condition-has-type? c &error-message)
@@ -202,13 +203,13 @@
   ;; Set the configuration if needed
   (when confdir
     (%stklos-conf-dir confdir))
-  
+
   ;; Look at the debug flag
   (when (> debug 0)
     (stklos-debug-level debug)
     (compiler:warn-use-undefined #t)	; Signal usage of still undefined symbols
     (compiler:gen-line-number #t)	; Generate line numbers
-    (when (> debug 1)			; Load-verbose when debug >= 2 
+    (when (> debug 1)			; Load-verbose when debug >= 2
       (load-verbose debug)))
 
   ;; Eventually try to create the configuratioon directory
@@ -222,13 +223,13 @@
   ;; Try to load the user initialization file except if "--no-init-file"
   (unless no-init
     (try-load (%stklos-conf-file "stklosrc")))
-  
+
   (when ld
     ;; "--load" option
     (with-handler
       (lambda (c) (%simple-fatal-exception-handler "loading file" ld c 7))
       (load ld)))
-  
+
   (cond
     ;; "--file" option
     (file (with-handler

lib/r7rs.stk

+;;;;
+;;;; r7rs.stk	-- R7RS support (Draft-1)
+;;;;
+;;;; Copyright © 2011 Erick Gallesio - Polytech'Nice-Sophia <eg@unice.fr>
+;;;;
+;;;;
+;;;; This program is free software; you can redistribute it and/or modify
+;;;; it under the terms of the GNU General Public License as published by
+;;;; the Free Software Foundation; either version 2 of the License, or
+;;;; (at your option) any later version.
+;;;;
+;;;; This program is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;;; GNU General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU General Public License
+;;;; along with this program; if not, write to the Free Software
+;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
+;;;; USA.
+;;;;
+;;;;           Author: Erick Gallesio [eg@unice.fr]
+;;;;    Creation date: 17-Apr-2011 19:36 (eg)
+;;;; Last file update: 17-Apr-2011 21:55 (eg)
+;;;;
+
+;;;; ----------------------------------------------------------------------
+;;;; 6.3 Other data types
+;;;; ----------------------------------------------------------------------
+
+;;;; ==== 6.3.2 Pairs and lists
+
+#|
+<doc r7rs-proc make-list
+ * (make-list k)
+ * (make-list k fill)
+ *
+ * Returns a newly allocated list of k elements. If a second
+ * argument is given, then each element is initialized to fill .
+ * Otherwise the initial contents of each element is unspecified.
+doc>
+|#
+(define (make-list k :optional (fill (void)))
+  (vector->list (make-vector k fill)))
+
+;;;; ----------------------------------------------------------------------
+;;;; 6.4 Control features
+;;;; ----------------------------------------------------------------------
+
+#|
+<doc r7rs-proc string-map
+ * (string-map proc string1 string2 ...)
+ *
+ * The |strings| must be strings, and |proc| must be a procedure taking as
+ * many arguments as there are strings and returning a single
+ * value. If more than one string is given and not all strings have the
+ * same length, |string-map| terminates when the shortest list runs
+ * out. |String-map| applies |proc| element-wise to the elements of the
+ * strings and returns a string of the results, in order. The dynamic
+ * order in which proc is applied to the elements of the |strings| is
+ * unspecified.
+ * @lisp
+ * (string-map char-downcase "AbdEgH"")
+ *          => "abdegh"
+ *
+ * (string-map
+ *   (lambda (c)
+ *     (integer->char (+ 1 (char->integer c))))
+ *   "HAL")
+ *          => "IBM"
+ *
+ * (string-map (lambda (c k)
+ * 	      (if (eqv? k #\u)
+ * 		  (char-upcase c)
+ * 		  (char-downcase c)))
+ * 	    "studlycaps"
+ * 	    "ululululul")
+ * 	 => "StUdLyCaPs"
+doc>
+|#
+(define (string-map proc . strings)
+  (let* ((strs (map (lambda (x)
+		      (unless (string? x)
+			(error 'string-map "bad string ~S" x))
+		      (string->list x))
+		    strings))
+	 (res (apply map proc strs)))
+    ;; Verify that every compnent of the result is a character
+    (unless (every char? res)
+      (error 'string-map "bad character in ~S" res))
+    ;; Return result
+    (list->string res)))
+
+#|
+<doc r7rs-proc vector-map
+ * (vector-map proc vector1 vector2 ...)
+ *
+ * The |vectors| must be vectors, and |proc| must be a procedure
+ * taking as many arguments as there are vectors and returning a single
+ * value. If more than one vector is given and not all vectors have the
+ * same length, |vector-map| terminates when the shortest list runs
+ * out. |Vector-map| applies |proc| element-wise to the elements of the
+ * vectors and returns a vector of the results, in order. The dynamic
+ * order in which proc is applied to the elements of the |vectors| is
+ * unspecified.
+ * @lisp
+ * (vector-map cadr '#((a b) (d e) (g h)))
+ *     =>  #(b e h)
+ *
+ * (vector-map (lambda (n) (expt n n))
+ * 	    '#(1 2 3 4 5))
+ *     => #(1 4 27 256 3125)
+ *
+ * (vector-map + '#(1 2 3) '#(4 5 6))
+ *     => #(5 7 9)
+ *
+ * (let ((count 0))
+ *   (vector-map
+ *     (lambda (ignored)
+ *       (set! count (+ count 1))
+ *       count)
+ *     '#(a b)))
+ *     => #(1 2) or #(2 1)
+ * @end lisp
+doc>
+|#
+(define (vector-map proc . vectors)
+  (unless (every vector? vectors)
+    (error 'vector-map "bad list of vectors ~S" vectors))
+  (list->vector (apply map proc (map vector->list vectors))))
+
+#|
+<doc r7rs-proc string-for-each
+ * (string-for-each proc string1 string2 ...)
+ *
+ * The arguments to |string-for-each| are like the arguments to
+ * |string-map|, but |string-for-each| calls |proc| for its side effects
+ * rather than for its values. Unlike |string-map|, |string-for-each| is
+ * guaranteed to call |proc| on the elements of the lists in order from
+ * the first element(s) to the last, and the value returned by
+ * |string-for-each| is unspecified. If more than one string is given and
+ * not all strings have the same length, |string-for-each| terminates when
+ * the shortest string runs out.
+ * @lisp
+ * (let ((v (list)))
+ *   (string-for-each (lambda (c) (set! v (cons (char->integer c) v)))
+ * 	              "abcde")
+ *    v)
+ *        => (101 100 99 98 97)
+ * @end lisp
+doc>
+|#
+(define (string-for-each proc . strings)
+  (let ((strs (map (lambda (x)
+		     (unless (string? x)
+		       (error 'string-for-each "bad string ~S" x))
+		     (string->list x))
+		   strings)))
+    (apply map proc strs)
+    (void)))
+
+
+#|
+<doc r7rs-proc vector-for-each
+ * (vector-for-each proc vector1 vector2 ...) 
+ *
+ * The arguments to |vector-for-each| are like the arguments to
+ * |vector-map|, but |vector-for-each| calls |proc| for its side effects
+ * rather than for its values. Unlike |vector-map|, |vector-for-each| is
+ * guaranteed to call |proc| on the elements of the lists in order from
+ * the first element(s) to the last, and the value returned by
+ * |vector-for-each| is unspecified. If more than one vector is given and
+ * not all vectors have the same length, |vector-for-each| terminates when
+ * the shortest vector runs out.
+ * @lisp
+ * (let ((v (make-vector 5)))
+ *   (vector-for-each (lambda (i) (vector-set! v i (* i i)))
+ * 		   '#(0 1 2 3 4))
+ *   v)
+ *        => #(0 1 4 9 16)
+ * @end lisp
+doc>
+|#
+(define (vector-for-each proc . vectors)
+  (unless (every vector? vectors)
+    (error 'vector-for-each "bad list of vectors ~S" vectors))
+  (apply map proc (map vector->list vectors))
+  (void))

tests/test-r7rs.stk

+;;;;							-*- coding: latin-1 -*-
+;;;;
+;;;; test-r7rs.stk	-- Testing R7RS constructs/primitives
+;;;;
+;;;; Copyright © 2011 Erick Gallesio - Polytech'Nice-Sophia <eg@unice.fr>
+;;;;
+;;;;
+;;;; This program is free software; you can redistribute it and/or modify
+;;;; it under the terms of the GNU General Public License as published by
+;;;; the Free Software Foundation; either version 2 of the License, or
+;;;; (at your option) any later version.
+;;;;
+;;;; This program is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;;; GNU General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU General Public License
+;;;; along with this program; if not, write to the Free Software
+;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
+;;;; USA.
+;;;;
+;;;;           Author: Erick Gallesio [eg@unice.fr]
+;;;;    Creation date: 17-Apr-2011 20:58 (eg)
+;;;; Last file update: 17-Apr-2011 21:48 (eg)
+;;;;
+
+(require "test")
+
+(test-section "R7RS")
+
+;;------------------------------------------------------------------
+(test-subsection "Control features")
+
+(test "string-map 1"  "abdegh"  (string-map char-downcase "AbdEgH"))
+(test "string-map 2"  "IBM"     (string-map (lambda (c)
+					      (integer->char (+ 1 (char->integer c))))
+					    "HAL"))
+(test "string-map 3"  "StUdLyCaPs"  (string-map (lambda (c k)
+						  (if (eqv? k #\u)
+						      (char-upcase c)
+						      (char-downcase c)))
+						"studlycaps"
+						"ululululul"))
+;; **********
+(test "vector-map 1"
+      #(b e h)
+      (vector-map cadr '#((a b) (d e) (g h))))
+
+(test "vector-map 2" #(1 4 27 256 3125)
+      (vector-map (lambda (n) (expt n n))
+		  '#(1 2 3 4 5)))
+
+(test "vector-map 3" #(5 7 9)
+      (vector-map + '#(1 2 3) '#(4 5 6)))
+
+(test "vector-map 4"  #(1 2)
+      (let ((count 0))
+	(vector-map (lambda (ignored)
+		      (set! count (+ count 1))
+		      count)
+		    '#(a b))))
+
+;; **********
+(test "string-for-each"
+      '(101 100 99 98 97)
+      (let ((v (list)))
+	(string-for-each (lambda (c) (set! v (cons (char->integer c) v)))
+			 "abcde")
+	 v))
+
+;; **********
+(test "vector-for-each"
+      '#(0 1 4 9 16)
+      (let ((v (make-vector 5)))
+	(vector-for-each (lambda (i) (vector-set! v i (* i i)))
+			 '#(0 1 2 3 4))
+	v))