From: Mikael Djurfeldt <mikael@djurfeldt.com>
To: guile-user@gnu.org, guile-devel@gnu.org
Subject: Re: Scmutils in guile-2.0
Date: Wed, 13 Feb 2013 23:10:23 +0100 [thread overview]
Message-ID: <CAA2Xvw+sASN92Ts4Wj3HchOVywO7CmhzN3L4d6uy7JRuWWqrZQ@mail.gmail.com> (raw)
In-Reply-To: <87y5ezyt9p.fsf@gnu.org>
[-- Attachment #1: Type: text/plain, Size: 126 bytes --]
Daniel Gildea reported problems for guile-2.0 guile-scmutils. Those
are fixed in the attached diff.
Best regards,
Mikael D.
[-- Attachment #2: guile-scmutils-v0.8-2.0-2.diff --]
[-- Type: application/octet-stream, Size: 14245 bytes --]
diff -ur guile-scmutils/src/calculus/interior-product.scm guile-scmutils-2.0/src/calculus/interior-product.scm
--- guile-scmutils/src/calculus/interior-product.scm 2006-11-04 21:20:27.000000000 +0100
+++ guile-scmutils-2.0/src/calculus/interior-product.scm 2013-02-07 11:31:16.368287479 +0100
@@ -24,19 +24,20 @@
;|#
(define (interior-product X)
- (assert (vector-field? X) "X not a vector field: interior-product")
(define (ix alpha)
(assert (form-field? alpha) "alpha not a form field: interior-product")
(let ((p (get-rank alpha)))
- (assert (> p 0) "Rank of form not greater than zero: interior-product")
(define (the-product . args)
(assert (= (length args) (- p 1))
"Wrong number of arguments to interior product")
(apply alpha (cons X args)))
+ (assert (> p 0) "Rank of form not greater than zero: interior-product")
(procedure->nform-field the-product
`((interior-product ,(diffop-name X))
,(diffop-name alpha))
(- p 1))))
+ (assert (vector-field? X) "X not a vector field: interior-product")
+
ix)
\f
;#|
diff -ur guile-scmutils/src/calculus/manifold.scm guile-scmutils-2.0/src/calculus/manifold.scm
--- guile-scmutils/src/calculus/manifold.scm 2006-11-04 21:20:27.000000000 +0100
+++ guile-scmutils-2.0/src/calculus/manifold.scm 2013-02-07 11:28:55.658414853 +0100
@@ -87,10 +87,6 @@
(lambda (point)
(s:map/r simplify-numerical-expression
point)))))
- (if (and (not (fix:= n (manifold 'dimension)))
- (not (eq? coordinate-system-name 'embedding)))
- (error "Coordinate system does not have dimension of manifold"
- coordinate-system-name (manifold 'manifold-name)))
(define (the-coordinate-system m)
(case m
((manifold) manifold)
@@ -178,6 +174,11 @@
(else
(error "Unknown message: coordinate-system"
coordinate-system-name (manifold 'manifold-name)))))))
+ (if (and (not (fix:= n (manifold 'dimension)))
+ (not (eq? coordinate-system-name 'embedding)))
+ (error "Coordinate system does not have dimension of manifold"
+ coordinate-system-name (manifold 'manifold-name)))
+
((manifold 'new-coordinates) the-coordinate-system)))
(list coordinate-system-name (manifold 'name)))
diff -ur guile-scmutils/src/calculus/speedup.scm guile-scmutils-2.0/src/calculus/speedup.scm
--- guile-scmutils/src/calculus/speedup.scm 2006-11-04 22:50:58.000000000 +0100
+++ guile-scmutils-2.0/src/calculus/speedup.scm 2013-02-07 11:32:59.005663142 +0100
@@ -276,7 +276,6 @@
(assert (tensor-field? g) "Not a tensor field.")
(let ((type (tensor-type g)))
(let ((u (car type)) (d (cdr type)))
- (assert (and (fix:= u 0) (fix:= d 2)) "Not a 2-down metric")
(define ((the-inverted-metric w1 w2) m)
(let* ((coeffs
((tensor-field->coefficient-structure g coordinate-system) m))
@@ -292,6 +291,7 @@
((tensor-manifold g)
'point-prototype))
m)))
+ (assert (and (fix:= u 0) (fix:= d 2)) "Not a 2-down metric")
(make-tensor-field d u
the-inverted-metric
`(invert ,(diffop-name g))
diff -ur guile-scmutils/src/calculus/tensor.scm guile-scmutils-2.0/src/calculus/tensor.scm
--- guile-scmutils/src/calculus/tensor.scm 2006-11-04 21:20:28.000000000 +0100
+++ guile-scmutils-2.0/src/calculus/tensor.scm 2013-02-07 11:32:11.057020636 +0100
@@ -263,7 +263,6 @@
"Metric tensor and the coordinate system must have the same manifold.")
(let ((type (tensor-type g)))
(let ((u (car type)) (d (cdr type)))
- (assert (and (fix:= u 0) (fix:= d 2)) "Not a 2-down metric")
(define ((the-inverted-metric w1 w2) m)
(let ((coeffs
((tensor-field->coefficient-structure g coordinate-system) m)))
@@ -271,6 +270,7 @@
(((coefficient-structure->tensor-field icoeffs coordinate-system)
w1 w2)
m))))
+ (assert (and (fix:= u 0) (fix:= d 2)) "Not a 2-down metric")
(make-tensor-field d u
the-inverted-metric
`(invert ,(diffop-name g))
diff -ur guile-scmutils/src/compat.scm guile-scmutils-2.0/src/compat.scm
--- guile-scmutils/src/compat.scm 2009-04-13 15:37:51.000000000 +0200
+++ guile-scmutils-2.0/src/compat.scm 2013-02-13 23:06:07.815695350 +0100
@@ -26,6 +26,8 @@
; guile (define* (proc (#:optional arg)) ...
; (lambda* (proc (#:optional arg)) ...
;;;;;
+(cond-expand (guile-2
+ (use-modules (ice-9 curried-definitions))))
(use-modules (ice-9 optargs))
(define (default-object? x)
(eq? #f x))
@@ -67,8 +69,12 @@
;(require 'fluid-let) ; deprecated
; ignore integrable
-(define define-integrable define)
-
+(cond-expand (guile-2
+ (define-syntax define-integrable
+ (syntax-rules ()
+ ((_ form body ...) (define-inlinable form body ...)))))
+ (else
+ (define define-integrable define)))
@@ -115,12 +121,15 @@
; guile 1.6 does not have numerator/denominator
; but guile 1.8 does
-(if (not (defined? 'numerator))
- (define (numerator x) x))
-(if (not (defined? 'denominator))
- (define (denominator x) 1))
-(if (not (defined? 'rationalize))
- (define (rationalize x err) x))
+(cond-expand (guile-2
+ )
+ (else
+ (if (not (defined? 'numerator))
+ (define (numerator x) x))
+ (if (not (defined? 'denominator))
+ (define (denominator x) 1))
+ (if (not (defined? 'rationalize))
+ (define (rationalize x err) x))))
(define fix:fixnum? number?)
@@ -171,8 +180,8 @@
(define string->uninterned-symbol gensym)
(use-modules (ice-9 pretty-print))
-(define pp pretty-print)
-
+(define* (pp object #:optional (output-port (current-output-port)) (as-code #f))
+ (pretty-print object output-port))
(define (guarantee-exact-positive-integer x msg)
(if (not (exact-positive-integer? x))
@@ -182,10 +191,16 @@
(if (not (symbol? x))
(error msg x "not a symbol")))
+(define guile-procedure-arity
+ (if (defined? 'procedure-minimum-arity)
+ procedure-minimum-arity
+ (lambda (proc)
+ (assoc-ref (procedure-properties proc) 'arity))))
+
(define (procedure-arity proc)
; if apply hook, use arity of underlying procedure
- (let ((arity (or (assoc-ref (procedure-properties proc) 'apply-hook-arity)
- (assoc-ref (procedure-properties proc) 'arity))))
+ (let ((arity (or (procedure-property proc 'apply-hook-arity)
+ (guile-procedure-arity proc))))
; convert from guile arity: (min opt more-possible)
; to mit arity: (min . max) max is #f if more-possible
(cons (car arity)
@@ -220,9 +235,10 @@
(set-apply-proc
(set! proc (caddr args)))
(else (apply proc args)))))
+ (set-procedure-property! aph 'apply-hook? #t)
(if proc
(set-procedure-property! aph 'apply-hook-arity
- (assoc-ref (procedure-properties proc) 'arity)))
+ (guile-procedure-arity proc)))
aph)
; implementation of mit scheme apply-hook feature
@@ -235,14 +251,11 @@
(aph #:set-apply-proc #t proc)
(if proc
(set-procedure-property! aph 'apply-hook-arity
- (assoc-ref (procedure-properties proc) 'arity))))
+ (guile-procedure-arity proc))))
(define (apply-hook? proc)
-(and (procedure? proc)
- (assoc-ref (procedure-properties proc) 'arglist)
- (eq? (caaddr (assoc-ref (procedure-properties proc) 'arglist))
- 'get-apply-extra)))
+ (and (procedure? proc) (procedure-property proc 'apply-hook?)))
;;;;; some list routines that are part of mit scheme
@@ -256,8 +269,11 @@
(define (make-initialized-vector n proc)
(list->vector (make-initialized-list n proc)))
-(if (not (defined? 'vector-copy))
- (define (vector-copy v) (list->vector (vector->list v))))
+(cond-expand (guile-2
+ )
+ (else
+ (if (not (defined? 'vector-copy))
+ (define (vector-copy v) (list->vector (vector->list v))))))
(define (find-matching-item l pred)
(if (null? l)
diff -ur guile-scmutils/src/general/memoize.scm guile-scmutils-2.0/src/general/memoize.scm
--- guile-scmutils/src/general/memoize.scm 2006-11-05 00:31:23.000000000 +0100
+++ guile-scmutils-2.0/src/general/memoize.scm 2013-01-25 15:17:18.877332138 +0100
@@ -278,7 +278,7 @@
;;; are ALWAYS unprotected, so we cannot use a weak table here.
(define (hash-memoize f)
- (let ((table) (memo-hits) (memo-misses))
+ (let ((table #f) (memo-hits #f) (memo-misses #f))
(let ((info
(lambda ()
(list memo-hits memo-misses table)))
@@ -327,7 +327,7 @@
(let ((arity (procedure-arity proc)))
(let ((memoized-procedure
(cond ((equal? arity '(0 . 0))
- (let ((ran? #f) (value))
+ (let ((ran? #f) (value #f))
(lambda ()
(if ran?
value
diff -ur guile-scmutils/src/load-real.scm guile-scmutils-2.0/src/load-real.scm
--- guile-scmutils/src/load-real.scm 2007-05-15 02:33:49.000000000 +0200
+++ guile-scmutils-2.0/src/load-real.scm 2013-02-07 21:30:06.746070636 +0100
@@ -29,9 +29,12 @@
;(add-subsystem-identification! "\n ScmUtils" '("Mechanics " " Fall 2006"))
-(if (defined? 'scmutils-base-environment)
- (set-current-module scmutils-base-environment)
- (define scmutils-base-environment (current-module)))
+(define scmutils-base-environment
+ (if (defined? 'scmutils-base-environment)
+ (begin
+ (set-current-module scmutils-base-environment)
+ scmutils-base-environment)
+ (current-module)))
;(load "general/comutils.scm"); scmutils-base-environment)
diff -ur guile-scmutils/src/numerics/linear/svd.scm guile-scmutils-2.0/src/numerics/linear/svd.scm
--- guile-scmutils/src/numerics/linear/svd.scm 2006-11-05 13:50:07.000000000 +0100
+++ guile-scmutils-2.0/src/numerics/linear/svd.scm 2013-02-07 11:27:30.557298175 +0100
@@ -123,12 +123,12 @@
(let* ((m (num-rows a)) (n (num-cols a))
;;(nm (max n m))
(ierr 0)
- (g) (scale) (anorm)
- (l) (f) (h) (s)
- (its) (flag1) (flag2) (l1) (c) (flag3) (k1)
- (convergence)
- (x) (y) (z)
- (i)
+ (g #f) (scale #f) (anorm #f)
+ (l #f) (f #f) (h #f) (s #f)
+ (its #f) (flag1 #f) (flag2 #f) (l1 #f) (c #f) (flag3 #f) (k1 #f)
+ (convergence #f)
+ (x #f) (y #f) (z #f)
+ (i #f)
(*svd.a* (array-copy a))
(*svd.u* (array-copy a))
diff -ur guile-scmutils/src/primes.scm guile-scmutils-2.0/src/primes.scm
--- guile-scmutils/src/primes.scm 2009-04-13 15:34:59.000000000 +0200
+++ guile-scmutils-2.0/src/primes.scm 2013-01-25 15:02:31.308498819 +0100
@@ -94,7 +94,10 @@
(or (null? lst) (and (= 1 (gcd n (car lst))) (mapf (cdr lst)))))))
(define prime:prime-sqr 121)
(define prime:products '(105))
-(define prime:sieve (list->uniform-vector #\nul '(0 0 1 1 0 1 0 1 0 0 0)))
+(define prime:sieve #f)
+(if (defined? 'list->s8vector)
+ (set! prime:sieve (list->s8vector '(0 0 1 1 0 1 0 1 0 0 0)))
+ (set! prime:sieve (list->uniform-vector #\nul '(0 0 1 1 0 1 0 1 0 0 0))))
(letrec ((lp (lambda (comp comps primes nexp)
(cond ((< comp (quotient most-positive-fixnum nexp))
(let ((ncomp (* nexp comp)))
diff -ur guile-scmutils/src/simplify/matcher.scm guile-scmutils-2.0/src/simplify/matcher.scm
--- guile-scmutils/src/simplify/matcher.scm 2006-11-01 02:43:34.000000000 +0100
+++ guile-scmutils-2.0/src/simplify/matcher.scm 2013-02-07 11:24:47.319155328 +0100
@@ -130,7 +130,6 @@
list-match)
\f
(define* (match:reverse-segment variable #:optional submatch)
- (if (default-object? submatch) (set! submatch match:equal))
(define (reverse-segment-match data dictionary succeed)
(if (list? data)
(let ((vcell (match:lookup variable dictionary)))
@@ -154,6 +153,7 @@
(else #f))))))
#f))
#f))
+ (if (default-object? submatch) (set! submatch match:equal))
reverse-segment-match)
(define (datum=? datum1 datum2)
diff -ur guile-scmutils/src/srfi-40.scm guile-scmutils-2.0/src/srfi-40.scm
--- guile-scmutils/src/srfi-40.scm 2007-02-17 22:16:59.000000000 +0100
+++ guile-scmutils-2.0/src/srfi-40.scm 2013-02-07 11:20:19.499573179 +0100
@@ -1,6 +1,23 @@
(use-modules (srfi srfi-9)) ; provides define-recored-type
(use-modules (ice-9 syncase)) ; provides define-syntax
+;;; STREAM -- LIBRARY OF SYNTAX AND FUNCTIONS TO MANIPULATE STREAMS
+
+;;; A stream is a new data type, disjoint from all other data types, that
+;;; contains a promise that, when forced, is either nil (a single object
+;;; distinguishable from all other objects) or consists of an object
+;;; (the stream element) followed by a stream. Each stream element is
+;;; evaluated exactly once, when it is first retrieved (not when it is
+;;; created); once evaluated its value is saved to be returned by
+;;; subsequent retrievals without being evaluated again.
+
+;; STREAM-TYPE -- type of streams
+;; STREAM? object -- #t if object is a stream, #f otherwise
+(define-record-type stream-type
+ (make-stream promise)
+ stream?
+ (promise stream-promise))
+
;;; PROMISES A LA SRFI-45:
;;; A separate implementation is necessary to
@@ -41,23 +58,6 @@
(srfi-40:force promise))))))
-;;; STREAM -- LIBRARY OF SYNTAX AND FUNCTIONS TO MANIPULATE STREAMS
-
-;;; A stream is a new data type, disjoint from all other data types, that
-;;; contains a promise that, when forced, is either nil (a single object
-;;; distinguishable from all other objects) or consists of an object
-;;; (the stream element) followed by a stream. Each stream element is
-;;; evaluated exactly once, when it is first retrieved (not when it is
-;;; created); once evaluated its value is saved to be returned by
-;;; subsequent retrievals without being evaluated again.
-
-;; STREAM-TYPE -- type of streams
-;; STREAM? object -- #t if object is a stream, #f otherwise
-(define-record-type stream-type
- (make-stream promise)
- stream?
- (promise stream-promise))
-
;;; UTILITY FUNCTIONS
;; STREAM-ERROR message -- print message then abort execution
diff -ur guile-scmutils/src/units/SI-units.scm guile-scmutils-2.0/src/units/SI-units.scm
--- guile-scmutils/src/units/SI-units.scm 2007-02-17 22:18:14.000000000 +0100
+++ guile-scmutils-2.0/src/units/SI-units.scm 2013-02-07 21:34:45.061695052 +0100
@@ -24,7 +24,8 @@
;|#
;;;; SI units
-(set-current-module generic-environment)
+(eval-when (compile load eval)
+ (set-current-module generic-environment))
(define-unit-system 'SI
(list 'meter "m" "length")
prev parent reply other threads:[~2013-02-13 22:10 UTC|newest]
Thread overview: 7+ messages / expand[flat|nested] mbox.gz Atom feed top
2013-02-07 20:46 Scmutils in guile-2.0 Mikael Djurfeldt
2013-02-07 22:00 ` Ludovic Courtès
2013-02-07 23:33 ` Mikael Djurfeldt
2013-02-08 9:54 ` Ludovic Courtès
2013-02-08 10:07 ` Mikael Djurfeldt
2013-02-08 10:49 ` Ludovic Courtès
2013-02-13 22:10 ` Mikael Djurfeldt [this message]
Reply instructions:
You may reply publicly to this message via plain-text email
using any one of the following methods:
* Save the following mbox file, import it into your mail client,
and reply-to-all from there: mbox
Avoid top-posting and favor interleaved quoting:
https://en.wikipedia.org/wiki/Posting_style#Interleaved_style
List information: https://www.gnu.org/software/guile/
* Reply using the --to, --cc, and --in-reply-to
switches of git-send-email(1):
git send-email \
--in-reply-to=CAA2Xvw+sASN92Ts4Wj3HchOVywO7CmhzN3L4d6uy7JRuWWqrZQ@mail.gmail.com \
--to=mikael@djurfeldt.com \
--cc=guile-devel@gnu.org \
--cc=guile-user@gnu.org \
/path/to/YOUR_REPLY
https://kernel.org/pub/software/scm/git/docs/git-send-email.html
* If your mail client supports setting the In-Reply-To header
via mailto: links, try the mailto: link
Be sure your reply has a Subject: header at the top and a blank line
before the message body.
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).