diff --git a/collects/mzlib/class.ss b/collects/mzlib/class.ss index b8822e2..97800da 100644 --- a/collects/mzlib/class.ss +++ b/collects/mzlib/class.ss @@ -1393,7 +1393,7 @@ (define (do-make-object class by-pos-args named-args) (unless (class? class) - (raise-type-error 'make-object "class" class)) + (raise-type-error 'instantiate "class" class)) (let ([o ((class-make-object class))]) ;; Initialize it: (let loop ([c class][by-pos-args by-pos-args][named-args named-args][explict-named-args? #t]) @@ -1403,7 +1403,7 @@ (unless (null? named-args) (if explict-named-args? (obj-error - 'make-object + 'instantiate "class has only by-position initializers, but given by-name arguments:~a~a" (make-named-arg-string named-args) (for-class (class-name c))) @@ -1430,7 +1430,7 @@ (append (map (lambda (x) (cons #f x)) al) named-args)] [else - (obj-error 'make-object + (obj-error 'instantiate "too many initialization arguments:~a~a" (make-pos-arg-string by-pos-args) (for-class (class-name c)))]))] @@ -1457,7 +1457,7 @@ ;; ----- This is the super-init function ----- (lambda (ignore-false by-pos-args new-named-args) (when inited? - (obj-error 'make-object "superclass already initialized by class initialization~a" + (obj-error 'instantiate "superclass already initialized by class initialization~a" (for-class (class-name c)))) (set! inited? #t) (let ([named-args (if (eq? 'list (class-init-mode c)) @@ -1473,7 +1473,7 @@ (pair? new-named-args)))) named-args) (unless inited? - (obj-error 'make-object "superclass initialization not invoked by initialization~a" + (obj-error 'instantiate "superclass initialization not invoked by initialization~a" (for-class (class-name c)))))))) o)) @@ -1490,7 +1490,7 @@ [(< name (length arguments)) (cdr (list-ref arguments name))] [default (default)] - [else (obj-error 'make-object "too few initialization arguments")]))) + [else (obj-error 'instantiate "too few initialization arguments")]))) (define (extract-rest-args skip arguments) (if (< skip (length arguments)) @@ -1517,12 +1517,12 @@ (define (unused-args-error this args) (let ([arg-string (make-named-arg-string args)]) - (obj-error 'make-object "unused initialization arguments:~a~a" + (obj-error 'instantiate "unused initialization arguments:~a~a" arg-string (for-class/which "instantiated" (class-name (object-ref this)))))) (define (missing-argument-error class-name name) - (obj-error 'make-object "no argument for required init variable: ~a~a" + (obj-error 'instantiate "no argument for required init variable: ~a~a" name (if class-name (format " in class: ~a" class-name) ""))) diff --git a/collects/mzlib/list.ss b/collects/mzlib/list.ss index 15c67af..2b3bcf1 100644 --- a/collects/mzlib/list.ss +++ b/collects/mzlib/list.ss @@ -271,13 +271,20 @@ (format "list with ~a or more items" npos) x)])))) - (define second (polymorphic (lget 'second 2))) - (define third (polymorphic (lget 'third 3))) - (define fourth (polymorphic (lget 'fourth 4))) - (define fifth (polymorphic (lget 'fifth 5))) - (define sixth (polymorphic (lget 'sixth 6))) - (define seventh (polymorphic (lget 'seventh 7))) - (define eighth (polymorphic (lget 'eighth 8))) + ;; Gives the function a name: + (define-syntax (mk-lget stx) + (syntax-case stx () + [(_ name pos) + (syntax (polymorphic (let ([g (lget 'name pos)]) + (lambda (x) (g x)))))])) + + (define second (mk-lget second 2)) + (define third (mk-lget third 3)) + (define fourth (mk-lget fourth 4)) + (define fifth (mk-lget fifth 5)) + (define sixth (mk-lget sixth 6)) + (define seventh (mk-lget seventh 7)) + (define eighth (mk-lget eighth 8)) (define rest (polymorphic (lambda (x) (unless (pair? x) diff --git a/collects/mzlib/math.ss b/collects/mzlib/math.ss index 1f1956d..f8c9935 100644 --- a/collects/mzlib/math.ss +++ b/collects/mzlib/math.ss @@ -19,10 +19,15 @@ ;; sgn function (define sgn (lambda (x) - (cond - ((< x 0) -1) - ((> x 0) 1) - (else 0)))) + (if (exact? x) + (cond + ((< x 0) -1) + ((> x 0) 1) + (else 0)) + (cond + ((< x 0.0) -1.0) + ((> x 0.0) 1.0) + (else 0.0))))) ;; complex conjugate (define conjugate diff --git a/collects/mzlib/string.ss b/collects/mzlib/string.ss index 269d1bc..b95d9a1 100644 --- a/collects/mzlib/string.ss +++ b/collects/mzlib/string.ss @@ -8,6 +8,7 @@ expr->string newline-string string->literal-regexp-string + string->literal-replace-string regexp-match-exact?) (require (lib "etc.ss")) @@ -124,6 +125,9 @@ [else (list c)])) (string->list s)))))) + (define (string->literal-replace-string s) + (regexp-replace* "\\\\" s "\\\\\\\\")) + (define regexp-match-exact? (lambda (p s) (let ([m (regexp-match p s)])