diff --git a/Makefile b/Makefile index 37ccd92..6bf08c1 100644 --- a/Makefile +++ b/Makefile @@ -83,7 +83,7 @@ am__include = include am__quote = install_sh = /Users/ikarus/Work/ikarus-scheme/install-sh AUTOMAKE_OPTIONS = foreign -SUBDIRS = src scheme +SUBDIRS = src scheme doc subdir = . ACLOCAL_M4 = $(top_srcdir)/aclocal.m4 mkinstalldirs = $(SHELL) $(top_srcdir)/mkinstalldirs diff --git a/Makefile.am b/Makefile.am index e169cac..a6876f0 100644 --- a/Makefile.am +++ b/Makefile.am @@ -1,2 +1,2 @@ AUTOMAKE_OPTIONS = foreign -SUBDIRS = src scheme +SUBDIRS = src scheme doc diff --git a/Makefile.in b/Makefile.in index be57c7f..d38797a 100644 --- a/Makefile.in +++ b/Makefile.in @@ -83,7 +83,7 @@ am__include = @am__include@ am__quote = @am__quote@ install_sh = @install_sh@ AUTOMAKE_OPTIONS = foreign -SUBDIRS = src scheme +SUBDIRS = src scheme doc subdir = . ACLOCAL_M4 = $(top_srcdir)/aclocal.m4 mkinstalldirs = $(SHELL) $(top_srcdir)/mkinstalldirs diff --git a/configure b/configure index 83cbdd7..a0ebcec 100755 --- a/configure +++ b/configure @@ -7306,7 +7306,7 @@ _ACEOF fi done - ac_config_files="$ac_config_files Makefile src/Makefile scheme/Makefile" + ac_config_files="$ac_config_files Makefile src/Makefile scheme/Makefile doc/Makefile" cat >confcache <<\_ACEOF # This file is a shell script that caches the results of configure # tests run on this system so they can be shared between configure @@ -7878,6 +7878,7 @@ do "Makefile" ) CONFIG_FILES="$CONFIG_FILES Makefile" ;; "src/Makefile" ) CONFIG_FILES="$CONFIG_FILES src/Makefile" ;; "scheme/Makefile" ) CONFIG_FILES="$CONFIG_FILES scheme/Makefile" ;; + "doc/Makefile" ) CONFIG_FILES="$CONFIG_FILES doc/Makefile" ;; "depfiles" ) CONFIG_COMMANDS="$CONFIG_COMMANDS depfiles" ;; *) { { echo "$as_me:$LINENO: error: invalid argument: $ac_config_target" >&5 echo "$as_me: error: invalid argument: $ac_config_target" >&2;} diff --git a/configure.ac b/configure.ac index cd28f1a..e380c15 100644 --- a/configure.ac +++ b/configure.ac @@ -59,4 +59,4 @@ AC_FUNC_STAT AC_FUNC_STRFTIME AC_FUNC_STRTOD AC_CHECK_FUNCS([bzero gettimeofday memmove memset munmap setenv sqrt strerror]) -AC_OUTPUT(Makefile src/Makefile scheme/Makefile) +AC_OUTPUT(Makefile src/Makefile scheme/Makefile doc/Makefile) diff --git a/doc/ikarus-users-guide.tex b/doc/ikarus-users-guide.tex index 3b620dc..7de7f8e 100644 --- a/doc/ikarus-users-guide.tex +++ b/doc/ikarus-users-guide.tex @@ -780,6 +780,9 @@ makes all of \texttt{(iteration)}'s exported identifiers, e.g. \section{\texttt{(ikarus library-manager)}} \newpage + +% \chapter{Using \rnrs{6} Libraries Effectively} + % \chapter{Additional Libraries} % % \section{\texttt{(iu match)}} diff --git a/scheme/ikarus.boot.orig b/scheme/ikarus.boot.orig index 85404e3..37b5fdc 100644 Binary files a/scheme/ikarus.boot.orig and b/scheme/ikarus.boot.orig differ diff --git a/scheme/ikarus.records.procedural.ss b/scheme/ikarus.records.procedural.ss index f482f6a..f2818b2 100644 --- a/scheme/ikarus.records.procedural.ss +++ b/scheme/ikarus.records.procedural.ss @@ -212,109 +212,46 @@ [else (error who "~s is not a valid record constructor descriptor" prcd)])))) - (define (iota i n) - (if (= i n) - '() - (cons i (iota (+ i 1) n)))) - - (define (sym n) - (string->symbol (format "v~s" n))) - - (define general-base-constructor - (lambda (n) - (lambda (rtd) - (lambda args - (unless (= (length args) n) - (error 'record-constructor - "incorrect number of arguments to constructor")) - (let f ([r ($make-struct rtd n)] [i 0] [args args]) - (cond - [(null? args) r] - [else - ($struct-set! r i (car args)) - (f r (add1 i) (cdr args))])))))) - - (define base-constructors - '#(#f #f #f #f #f #f #f #f #f #f #f #f)) - - (define (base-constructor-maker n) - (cond - [(< n (vector-length base-constructors)) - (or (vector-ref base-constructors n) - (let ([vars (map sym (iota 0 n))]) - (let ([proc - (eval `(lambda (rtd) - (lambda ,vars - ($struct rtd . ,vars))) - (environment - '(ikarus) - '(ikarus system $structs)))]) - (vector-set! base-constructors n proc) - proc)))] - [else (general-base-constructor n)])) - - (define extended-constructors - '#(#f #f #f #f #f #f #f #f #f #f #f #f)) - - (define general-extended-constructor - (lambda (n m) - (lambda (record-constructor) - (lambda args-n - (unless (= (length args-n) n) - (error 'record-constructor "incorrect arguments")) - (lambda args-m - (unless (= (length args-m) m) - (error 'record-constructor "incorrect arguments")) - (apply record-constructor (append args-n args-m))))))) - - (define (extended-constructor-maker n m) - (cond - [(< n (vector-length extended-constructors)) - (let ([v (let ([v (vector-ref extended-constructors n)]) - (or v - (let ([v (make-vector (+ n 1) #f)]) - (vector-set! extended-constructors n v) - v)))]) - (or (vector-ref v m) - (let* ([vars-0m (map sym (iota 0 m))] - [vars-mn (map sym (iota m n))] - [proc - (eval - `(lambda (record-constructor) - (lambda ,vars-0m - (lambda ,vars-mn - (record-constructor ,@vars-0m ,@vars-mn)))) - (environment '(ikarus)))]) - (vector-set! v m proc) - proc)))] - [else (general-extended-constructor n m)])) - (define (record-constructor rcd) (define who 'record-constructor) + (define (constructor main-rtd size prcd proto) + (if (not prcd) ;;; base + (lambda (f*) + (let ([v (lambda flds + (let ([n (rtd-size main-rtd)]) + (unless (= (length flds) size) + (error 'record-constructor + "expecting ~s args, got ~s" n flds)) + (let ([r ($make-struct main-rtd n)]) + (let f ([i 0] [r r] [flds flds] [f* f*]) + (cond + [(null? flds) + (if (null? f*) + r + (f i r (car f*) (cdr f*)))] + [else + ($struct-set! r i (car flds)) + (f (add1 i) r (cdr flds) f*)])))))]) + (if proto (proto v) v))) + (let ([pprcd (rcd-prcd prcd)] + [sz (rtd-size (rcd-rtd prcd))]) + (let ([p (constructor main-rtd sz pprcd (rcd-proc prcd))] + [n (- size sz)]) + (lambda (f*) + (let ([v (lambda fmls + (lambda flds + (unless (= (length flds) n) + (error 'record-constructor + "expecting ~s args, got ~s" n flds)) + (apply (p (cons flds f*)) fmls)))]) + (if proto (proto v) v))))))) (unless (rcd? rcd) (error who "~s is not a record constructor descriptor" rcd)) (let ([rtd (rcd-rtd rcd)] - [prcd (rcd-prcd rcd)]) - (let ([c* - (let ([n (rtd-size rtd)]) - (let f ([c0 ((base-constructor-maker n) rtd)] - [prcd prcd] - [n n]) - (cond - [(not prcd) c0] - [else - (let ([r (rcd-rtd prcd)]) - (let ([m (rtd-size r)]) - (f ((extended-constructor-maker n m) c0) - (rcd-prcd prcd) - m)))])))]) - (let f ([rcd rcd]) - (cond - [(not rcd) c*] - [else - (let ([c* (f (rcd-prcd rcd))]) - (let ([proc (rcd-proc rcd)]) - (if proc (proc c*) c*)))]))))) + [prcd (rcd-prcd rcd)] + [proto (rcd-proc rcd)]) + ((constructor rtd (rtd-size rtd) prcd proto) '()))) + (define (record-accessor rtd k) (define who 'record-accessor) @@ -413,3 +350,65 @@ (rtd-name (rcd-rtd x))) p))) ) + + +#!eof + +rtd0 fields=4 +proto0 = + (lambda (n) + (lambda (p0-fmls ...) + (n f0 f1 f2 f3))) + +rtd1 fields=2 +proto1 = + (lambda (n) + (lambda (p1-fmls ...) + ((n p0-acts ...) f4 f5))) + +rtd2 fields=1 +proto2 = + (lambda (n) + (lambda (p2-fmls ...) + ((n p1-acts ...) f6))) + + +(record-constructor rcd2) +== +(proto2 (lambda p1-fml* + (lambda (f6) + (apply (proto1 (lambda p0-fml* + (lambda (f4 f5) + (apply (proto0 (lambda (f0 f1 f2 f3) + ($record rtd2 f0 f1 f2 f3 f4 f5 f6))) + p0-fml*)))) + p1-fml*)))) + +new0 = (lambda (f0 f1 f2 f3 f4 f5 f6) + ($record rtd2 f0 f1 f2 f3 f4 f5 f6)) + +(record-constructor rcd2) +== +(proto2 (lambda p1-fml* + (lambda (f6) + (apply (proto1 (lambda p0-fml* + (lambda (f4 f5) + (apply (proto0 (lambda (f0 f1 f2 f3) + (new0 f0 f1 f2 f3 f4 f5 f6))) + p0-fml*)))) + p1-fml*)))) + + + + + + + + + + + + + + + diff --git a/scheme/tests/r6rs-records-procedural.ss b/scheme/tests/r6rs-records-procedural.ss index 5303ed9..92cf666 100755 --- a/scheme/tests/r6rs-records-procedural.ss +++ b/scheme/tests/r6rs-records-procedural.ss @@ -1,4 +1,4 @@ -#!/usr/bin/env ikarus --r6rs-script +#!/usr/bin/env ikarus -b ikarus.boot --r6rs-script (import (ikarus) @@ -202,11 +202,17 @@ (test0) +(printf "test0 ok\n") (test1) +(printf "test1 ok\n") (test2) +(printf "test2 ok\n") (test3) +(printf "test3 ok\n") (test4) +(printf "test4 ok\n") (test5) +(printf "test5 ok\n") (printf "rtd0=~s\n" rtd0) (printf "rcd0=~s\n" rcd0-default) (printf "fields of ~s are ~s\n" rtd1 (record-type-field-names rtd1))