Commit 581d54a4 authored by Erick's avatar Erick

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
parent c26dbc70
......@@ -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
......
......@@ -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
......
;;;;
;;;; 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
......
;;;;
;;;; 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))
This diff is collapsed.
This diff is collapsed.
;;;; -*- 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))
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment