* Fixed implementation of record-constructor in (rnrs records procedural)
This commit is contained in:
Abdulaziz Ghuloum
parent
d23267745e
commit
658e441d6c
2
Makefile
2
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
|
||||
|
|
|
|||
|
|
@ -1,2 +1,2 @@
|
|||
AUTOMAKE_OPTIONS = foreign
|
||||
SUBDIRS = src scheme
|
||||
SUBDIRS = src scheme doc
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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;}
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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)}}
|
||||
|
|
|
|||
Binary file not shown.
|
|
@ -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*))))
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
|
|||
Loading…
Reference in New Issue