>From 375569e33f93ba54fd0b65e5449d08ba8fc67788 Mon Sep 17 00:00:00 2001 From: Peter Bex Date: Sun, 23 Sep 2012 22:29:41 +0200 Subject: [PATCH] Remove everything marked DEPRECATED and the tests that still used them. Removed a few type annotations that were forgotten last time --- batch-driver.scm | 17 +-- c-platform.scm | 3 - chicken-install.scm | 3 +- chicken-profile.scm | 3 +- chicken-status.scm | 3 +- chicken-syntax.scm | 3 - chicken-uninstall.scm | 3 +- chicken.h | 12 -- compiler.scm | 3 +- csc.scm | 3 - csi.scm | 5 +- data-structures.import.scm | 4 - data-structures.scm | 11 -- expand.scm | 36 ++---- library.scm | 2 - lolevel.import.scm | 3 - lolevel.scm | 8 - runtime.c | 21 +--- setup-api.scm | 204 ----------------------------- srfi-13.scm | 35 +++--- srfi-69.scm | 27 ++-- tests/lolevel-tests.scm | 17 --- tests/module-tests.scm | 5 +- tests/numbers-string-conversion-tests.scm | 4 +- types.db | 14 -- 25 files changed, 60 insertions(+), 389 deletions(-) diff --git a/batch-driver.scm b/batch-driver.scm index bad5052..062bb6b 100644 --- a/batch-driver.scm +++ b/batch-driver.scm @@ -325,17 +325,12 @@ ;; Insert postponed initforms: (set! initforms (append initforms postponed-initforms)) - (let ((se (map string->symbol (collect-options 'static-extension)))) ; DEPRECATED - ;; Append required extensions to initforms: - (set! initforms - (append - initforms - (map (lambda (r) `(##core#require-extension (,r) #t)) - (append se (map string->symbol (collect-options 'require-extension)))))) - - ;; add static-extensions as used units: - (set! ##sys#explicit-library-modules - (append ##sys#explicit-library-modules se))) + ;; Append required extensions to initforms: + (set! initforms + (append + initforms + (map (lambda (r) `(##core#require-extension (,(string->symbol r)) #t)) + (collect-options 'require-extension)))) (when (memq 'compile-syntax options) (set! ##sys#enable-runtime-macros #t) ) diff --git a/c-platform.scm b/c-platform.scm index 32f9b88..facdbe7 100644 --- a/c-platform.scm +++ b/c-platform.scm @@ -92,19 +92,16 @@ no-bound-checks no-procedure-checks-for-usual-bindings no-compiler-syntax no-parentheses-synonyms no-symbol-escape r5rs-syntax emit-all-import-libraries strict-types clustering - lambda-lift unboxing ; OBSOLETE setup-mode no-module-registration) ) (define valid-compiler-options-with-argument '(debug output-file include-path heap-size stack-size unit uses keyword-style require-extension inline-limit profile-name - disable-warning ; OBSOLETE parenthesis-synonyms prelude postlude prologue epilogue nursery extend feature no-feature types emit-import-library emit-inline-file static-extension consult-inline-file emit-type-file - heap-growth heap-shrinkage heap-initial-size ; DEPRECATED ffi-define ffi-include-path) ) diff --git a/chicken-install.scm b/chicken-install.scm index b252e1d..32fae4d 100644 --- a/chicken-install.scm +++ b/chicken-install.scm @@ -915,8 +915,7 @@ EOF (set! *keep* #t) (set! *no-install* #t) (loop (cdr args) eggs)) - ((or (string=? arg "-v") ; DEPRECATED - (string=? arg "-version")) + ((string=? arg "-version") (print (chicken-version)) (exit 0)) ((or (string=? arg "-u") (string=? arg "-update-db")) diff --git a/chicken-profile.scm b/chicken-profile.scm index 8785b7b..6dbb684 100644 --- a/chicken-profile.scm +++ b/chicken-profile.scm @@ -92,8 +92,7 @@ EOF (if (and n (> n 0)) n (error "invalid argument to option" arg)))) (cond [(member arg '("-h" "-help" "--help")) (print-usage)] - [(member arg '("-v" ; DEPRECATED - "-version")) + [(string=? arg "-version") (print "chicken-profile - Version " (chicken-version)) (exit) ] [(string=? arg "-release") diff --git a/chicken-status.scm b/chicken-status.scm index 72c1342..8872c1c 100644 --- a/chicken-status.scm +++ b/chicken-status.scm @@ -175,8 +175,7 @@ EOF ((or (string=? arg "-f") (string=? arg "-files")) (set! files #t) (loop (cdr args) pats)) - ((or (string=? arg "-v") ; DEPRECATED - (string=? arg "-version")) + ((string=? arg "-version") (print (chicken-version)) (exit 0)) ((and (positive? (string-length arg)) diff --git a/chicken-syntax.scm b/chicken-syntax.scm index c8f0f63..9b283cc 100644 --- a/chicken-syntax.scm +++ b/chicken-syntax.scm @@ -1089,9 +1089,6 @@ (syntax-rules () ((_ name) (##core#define-compiler-syntax name #f)) - ((_ (name . llist) body ...) ; DEPRECATED - (define-compiler-syntax name - (##sys#er-transformer (lambda llist body ...) 'name))) ((_ name transformer) (##core#define-compiler-syntax name transformer)))) diff --git a/chicken-uninstall.scm b/chicken-uninstall.scm index 335dc56..bdcb55a 100644 --- a/chicken-uninstall.scm +++ b/chicken-uninstall.scm @@ -129,8 +129,7 @@ EOF (string=? arg "-h") (string=? arg "--help")) (usage 0)) - ((or (string=? arg "-v") ; DEPRECATED - (string=? arg "-version")) + ((string=? arg "-version") (print (chicken-version)) (exit 0)) ((string=? arg "-target") diff --git a/chicken.h b/chicken.h index 8293f07..8a6fcba 100644 --- a/chicken.h +++ b/chicken.h @@ -325,8 +325,6 @@ void *alloca (); #define ___byte char #define ___scheme_value C_word #define ___scheme_pointer void * -/* `___byte_vector' is DEPRECATED */ -#define ___byte_vector unsigned char * #define ___blob void * #define ___pointer_vector void ** #define ___symbol char * @@ -1347,10 +1345,6 @@ extern double trunc(double); #define C_u_i_u32vector_ref(x, i) C_fix(((C_u32 *)C_data_pointer(C_block_item((x), 1)))[ C_unfix(i) ]) #define C_u_i_s32vector_ref(x, i) C_fix(((C_u32 *)C_data_pointer(C_block_item((x), 1)))[ C_unfix(i) ]) -/* DEPRECATED */ -#define C_a_i_u32vector_ref C_a_u_i_u32vector_ref -#define C_a_i_s32vector_ref C_a_u_i_s32vector_ref - #define C_a_u_i_u32vector_ref(ptr, c, x, i) C_unsigned_int_to_num(ptr, ((C_u32 *)C_data_pointer(C_block_item((x), 1)))[ C_unfix(i) ]) #define C_a_u_i_s32vector_ref(ptr, c, x, i) C_int_to_num(ptr, ((C_s32 *)C_data_pointer(C_block_item((x), 1)))[ C_unfix(i) ]) @@ -1485,10 +1479,6 @@ extern double trunc(double); #define C_a_i_flonum_floor(ptr, n, x) C_flonum(ptr, C_floor(C_flonum_magnitude(x))) #define C_a_i_flonum_round(ptr, n, x) C_flonum(ptr, C_round(C_flonum_magnitude(x))) -/* DEPRECATED */ -#define C_a_i_f32vector_ref C_a_u_i_f32vector_ref -#define C_a_i_f64vector_ref C_a_u_i_f64vector_ref - #define C_a_u_i_f32vector_ref(ptr, n, b, i) C_flonum(ptr, ((float *)C_data_pointer(C_block_item((b), 1)))[ C_unfix(i) ]) #define C_a_u_i_f64vector_ref(ptr, n, b, i) C_flonum(ptr, ((double *)C_data_pointer(C_block_item((b), 1)))[ C_unfix(i) ]) #define C_u_i_f32vector_set(v, i, x) ((((float *)C_data_pointer(C_block_item((v), 1)))[ C_unfix(i) ] = C_flonum_magnitude(x)), C_SCHEME_UNDEFINED) @@ -1654,8 +1644,6 @@ C_fctexport void C_fcall C_trace(C_char *name) C_regparm; C_fctexport C_word C_fcall C_emit_trace_info2(char *raw, C_word x, C_word y, C_word t) C_regparm; C_fctexport C_word C_fcall C_u_i_string_hash(C_word str, C_word rnd) C_regparm; C_fctexport C_word C_fcall C_u_i_string_ci_hash(C_word str, C_word rnd) C_regparm; -C_fctexport C_word C_fcall C_hash_string(C_word str) C_regparm; /* DEPRECATED, INSECURE */ -C_fctexport C_word C_fcall C_hash_string_ci(C_word str) C_regparm; /* DEPRECATED, INSECURE */ C_fctexport C_word C_halt(C_word msg); C_fctexport C_word C_message(C_word msg); C_fctexport C_word C_fcall C_equalp(C_word x, C_word y) C_regparm; diff --git a/compiler.scm b/compiler.scm index 94d178d..2932a44 100644 --- a/compiler.scm +++ b/compiler.scm @@ -1456,8 +1456,7 @@ (warning "invalid argument to `inline-limit' declaration" spec) ) ) ) - ((constant ; DEPRECATED - pure) + ((pure) (let ((syms (cdr spec))) (if (every symbol? syms) (for-each diff --git a/csc.scm b/csc.scm index 0ced1e4..b0a94b4 100644 --- a/csc.scm +++ b/csc.scm @@ -145,7 +145,6 @@ -emit-all-import-libraries -setup-mode -no-elevation -no-module-registration -no-procedure-checks-for-usual-bindings -module -specialize -strict-types -clustering - -lambda-lift -unboxing ; OBSOLETE -no-procedure-checks-for-toplevel-bindings)) (define-constant complex-options @@ -154,7 +153,6 @@ -inline-limit -profile-name -emit-inline-file -types -emit-type-file -feature -debug-level - -heap-growth -heap-shrinkage -heap-initial-size ; DEPRECATED -consult-inline-file -emit-import-library -no-feature)) @@ -165,7 +163,6 @@ (-S "-scrutinize") (-M "-module") (|-P| "-check-syntax") - (|-V| "-version") ; DEPRECATED (-f "-fixnum-arithmetic") (|-D| "-feature") (-i "-case-insensitive") diff --git a/csi.scm b/csi.scm index de17b74..99aed63 100644 --- a/csi.scm +++ b/csi.scm @@ -988,7 +988,6 @@ EOF (##sys#error "missing or invalid script argument")) (program-name (cadr script)) (command-line-arguments (cddr script)) - (register-feature! 'script) ; DEPRECATED (register-feature! 'chicken-script) (set-cdr! (cdr script) '()) (when ##sys#windows-platform @@ -1030,9 +1029,7 @@ EOF (when (member* '("-h" "-help" "--help") args) (print-usage) (exit 0) ) - (when (member* '("-v" ; DEPRECATED - "-version") - args) + (when (member "-version" args) (print-banner) (exit 0) ) (when (member "-setup-mode" args) diff --git a/data-structures.import.scm b/data-structures.import.scm index 7332141..729c0f4 100644 --- a/data-structures.import.scm +++ b/data-structures.import.scm @@ -30,7 +30,6 @@ alist-ref alist-update! alist-update - always? ; DEPRECATED any? atom? binary-search @@ -54,8 +53,6 @@ make-queue merge merge! - never? ; DEPRECATED - none? ; DEPRECATED o queue->list queue-add! @@ -69,7 +66,6 @@ queue? rassoc reverse-string-append - shuffle ; DEPRECATED sort sort! sorted? diff --git a/data-structures.scm b/data-structures.scm index 2ed9102..0ef3c5f 100644 --- a/data-structures.scm +++ b/data-structures.scm @@ -110,10 +110,6 @@ (define (any? x) #t) -(define (none? x) #f) ; DEPRECATED -(define (always? . _) #t) ; DEPRECATED -(define (never? . _) #f) ; DEPRECATED - ;;; List operators: @@ -198,13 +194,6 @@ (cons (##sys#slot lst 0) (loop (##sys#slot blst 1) (##sys#slot lst 1)))] [else (loop (##sys#slot blst 1) (##sys#slot lst 1))] ) ) ) ) ) -(define shuffle ; DEPRECATED - (lambda (l random) - (let ((len (length l))) - (map cdr - (sort! (map (lambda (x) (cons (random len) x)) l) - (lambda (x y) (< (car x) (car y)))) ) ) ) ) - ;;; Alists: diff --git a/expand.scm b/expand.scm index 660d1fa..5362d27 100644 --- a/expand.scm +++ b/expand.scm @@ -155,9 +155,9 @@ (define ##sys#chicken-ffi-macro-environment '()) ; used later in foreign.import.scm (define (##sys#ensure-transformer t #!optional loc) - (cond ((procedure? t) (##sys#slot (##sys#er-transformer t) 1)) ; DEPRECATED - ((##sys#structure? t 'transformer) (##sys#slot t 1)) - (else (##sys#error loc "expected syntax-transformer, but got" t)))) + (if (##sys#structure? t 'transformer) + (##sys#slot t 1) + (##sys#error loc "expected syntax-transformer, but got" t))) (define (##sys#extend-macro-environment name se transformer) (let ((me (##sys#macro-environment)) @@ -506,12 +506,7 @@ (let ((def (car body))) (loop (cdr body) - (cons (cond ((pair? (cadr def)) ; DEPRECATED - `(define-syntax ; (the first element is actually ignored) - ,(caadr def) - (##sys#er-transformer - (##core#lambda ,(cdadr def) ,@(cddr def))))) - ;; insufficient, if introduced by different expansions, but + (cons (cond ;; insufficient, if introduced by different expansions, but ;; better than nothing: ((eq? (car def) (cadr def)) (##sys#defjam-error def)) @@ -1002,23 +997,12 @@ (lambda (form r c) (let ((head (cadr form)) (body (cddr form)) ) - (cond ((not (pair? head)) - (##sys#check-syntax 'define-syntax head 'symbol) - (##sys#check-syntax 'define-syntax body '#(_ 1)) - (##sys#register-export head (##sys#current-module)) - (when (c (r 'define-syntax) head) - (##sys#defjam-error form)) - `(##core#define-syntax ,head ,(car body))) - (else ; DEPRECATED - (##sys#check-syntax 'define-syntax head '(_ . lambda-list)) - (##sys#check-syntax 'define-syntax body '#(_ 1)) - (when (eq? (car form) (car head)) - (##sys#syntax-error-hook - "redefinition of `define-syntax' not allowed in syntax-definition" - form)) - `(##core#define-syntax - ,(car head) - (##sys#er-transformer (##core#lambda ,(cdr head) ,@body)))))))))) + (##sys#check-syntax 'define-syntax head 'symbol) + (##sys#check-syntax 'define-syntax body '#(_ 1)) + (##sys#register-export head (##sys#current-module)) + (when (c (r 'define-syntax) head) + (##sys#defjam-error form)) + `(##core#define-syntax ,head ,(car body))))))) (##sys#extend-macro-environment 'let diff --git a/library.scm b/library.scm index bb30f39..c0f297c 100644 --- a/library.scm +++ b/library.scm @@ -3615,8 +3615,6 @@ EOF (let ([sym (string->symbol ((##core#primitive "C_build_platform")))]) (lambda () sym) ) ) -(define (c-runtime) 'unknown) ; DEPRECATED - (define ##sys#windows-platform (and (eq? 'windows (software-type)) ;; Still windows even if 'Linux-like' diff --git a/lolevel.import.scm b/lolevel.import.scm index bd0236c..b6f5bf8 100644 --- a/lolevel.import.scm +++ b/lolevel.import.scm @@ -43,10 +43,8 @@ make-pointer-vector make-weak-locative move-memory! - mutate-procedure ; DEPRECATED mutate-procedure! null-pointer - null-pointer? ; DEPRECATED number-of-bytes number-of-slots object->pointer @@ -60,7 +58,6 @@ object-unevict pointer->address pointer-like? - pointer-offset ; DEPRECATED pointer->object pointer-f32-ref pointer-f32-set! diff --git a/lolevel.scm b/lolevel.scm index b7e58fb..52b4318 100644 --- a/lolevel.scm +++ b/lolevel.scm @@ -222,12 +222,6 @@ EOF (##sys#check-special ptr 'pointer->address) (##sys#pointer->address ptr) ) -(define null-pointer ##sys#null-pointer) ; DEPRECATED - -(define (null-pointer? ptr) ; DEPRECATED - (##sys#check-special ptr 'null-pointer?) - (##core#inline "C_null_pointerp" ptr)) - (define (object->pointer x) (and (##core#inline "C_blockp" x) ((foreign-lambda* nonnull-c-pointer ((scheme-object x)) "C_return((void *)x);") x) ) ) @@ -623,8 +617,6 @@ EOF (##sys#become! (list (cons old (proc new)))) new ) ) -(define mutate-procedure mutate-procedure!) ; DEPRECATED - ;;; pointer vectors diff --git a/runtime.c b/runtime.c index 2673d81..c03294b 100644 --- a/runtime.c +++ b/runtime.c @@ -3765,18 +3765,6 @@ C_regparm C_word C_fcall C_u_i_string_ci_hash(C_word str, C_word rnd) return C_fix(hash_string(len, ptr, C_MOST_POSITIVE_FIXNUM, C_unfix(rnd), 1)); } -/* DEPRECATED, INSECURE */ -C_regparm C_word C_fcall C_hash_string(C_word str) -{ - return C_u_i_string_hash(str, C_fix(0)); -} - -/* DEPRECATED, INSECURE */ -C_regparm C_word C_fcall C_hash_string_ci(C_word str) -{ - return C_u_i_string_ci_hash(str, C_fix(0)); -} - C_regparm void C_fcall C_toplevel_entry(C_char *name) { if(debug_mode) @@ -7455,13 +7443,12 @@ C_regparm C_word C_fcall convert_string_to_number(C_char *str, int radix, C_word int len = C_strlen(str); if(radix == 10) { - if (len >= 4 && len <= 6) { /* DEPRECATED, TODO: Change to (len == 4) */ + if (len == 6) { if((*str == '+' || *str == '-') && C_strchr("inIN", *(str+1)) != NULL && C_strchr("naNA", *(str+2)) != NULL && C_strchr("fnFN", *(str+3)) != NULL && - /* DEPRECATED, TODO: Rip out len checks */ - (len == 4 || *(str+4) == '.') && (len == 5 || (*(str+5) == '0'))) { + *(str+4) == '.' && *(str+5) == '0') { if (*(str+1) == 'i' || *(str+1) == 'I') /* Inf */ *flo = 1.0/0.0; else /* NaN */ @@ -7471,15 +7458,11 @@ C_regparm C_word C_fcall convert_string_to_number(C_char *str, int radix, C_word return 2; } } - /* DEPRECATED (enable in next release) */ -#if 0 - /* This is disabled during the deprecation period of "+nan" syntax */ /* Prevent C parser from accepting things like "-inf" on its own... */ for(n = 0; n < len; ++n) { if (C_strchr("+-0123456789e.", *(str+n)) == NULL) return 0; } -#endif } if(C_strpbrk(str, "xX\0") != NULL) return 0; diff --git a/setup-api.scm b/setup-api.scm index 50ab484..956e7b2 100644 --- a/setup-api.scm +++ b/setup-api.scm @@ -39,7 +39,6 @@ ((run execute) compile standard-extension - make make/proc ; DEPRECATED host-extension install-extension install-program install-script setup-verbose-mode setup-install-mode deployment-mode @@ -54,7 +53,6 @@ test-compile try-compile run-verbose extra-features extra-nonfeatures copy-file move-file - required-chicken-version required-extension-version ;DEPRECATED sudo-install keep-intermediates version>=? extension-name-and-version @@ -261,12 +259,6 @@ (shellpath (substring prg 2))) (else (find-program prg)))) -(define (fixmaketarget file) - (if (and (equal? "so" (pathname-extension file)) - (not (string=? "so" ##sys#load-dynamic-extension)) ) - (pathname-replace-extension file ##sys#load-dynamic-extension) - file) ) - (define (execute explist) (define (smooth lst) (let ((slst (map ->string lst))) @@ -288,168 +280,6 @@ (run (csc exp ...))))) -;;; "make" functionality - -;;; DEPRECATED -;;; vvv - -(define (make:find-matching-line str spec) - (let ((match? (lambda (s) (string=? s str)))) - (let loop ((lines spec)) - (cond - ((null? lines) #f) - (else (let* ((line (car lines)) - (names (if (string? (car line)) - (list (car line)) - (car line)))) - (if (any match? names) - line - (loop (cdr lines))))))))) - -(define (make:form-error s p) (error (sprintf "~a: ~s" s p))) -(define (make:line-error s p n) (error (sprintf "~a: ~s for line: ~a" s p n))) - -(define (make:check-spec spec) - (and (or (list? spec) (make:form-error "specification is not a list" spec)) - (or (pair? spec) (make:form-error "specification is an empty list" spec)) - (every - (lambda (line) - (and (or (and (list? line) (<= 2 (length line) 3)) - (make:form-error "list is not a list with 2 or 3 parts" line)) - (or (or (string? (car line)) - (and (list? (car line)) - (every string? (car line)))) - (make:form-error "line does not start with a string or list of strings" line)) - (let ((name (car line))) - (or (list? (cadr line)) - (make:line-error "second part of line is not a list" (cadr line) name) - (every (lambda (dep) - (or (string? dep) - (make:form-error "dependency item is not a string" dep))) - (cadr line))) - (or (null? (cddr line)) - (procedure? (caddr line)) - (make:line-error "command part of line is not a thunk" (caddr line) name))))) - spec))) - -(define (make:check-argv argv) - (or (string? argv) - (every string? argv) - (error "argument-list to `make' is not a string or string list" argv))) - -(define (make:make/proc/helper spec argv) - (when (vector? argv) (set! argv (vector->list argv))) - (make:check-spec spec) - (make:check-argv argv) - (letrec ((made '()) - (exn? (condition-predicate 'exn)) - (exn-message (condition-property-accessor 'exn 'message)) - (make-file - (lambda (s indent) - (let* ((line (make:find-matching-line s spec)) - (s2 (fixmaketarget s)) - (date (and (file-exists? s2) - (file-modification-time s2)))) - (when (setup-verbose-mode) - (printf "make: ~achecking ~a~%" indent s2)) - (if line - (let ((deps (cadr line))) - (for-each (let ((new-indent (string-append " " indent))) - (lambda (d) (make-file d new-indent))) - deps) - (let ((reason - (or (not date) - (any (lambda (dep) - (let ((dep2 (fixmaketarget dep))) - (unless (file-exists? dep2) - ;;XXX internal error? - (error - (sprintf - "(make) dependency ~a was not made~%" - dep2))) - (and (> (file-modification-time dep2) date) - dep2)) ) - deps)))) - (when reason - (let ((l (cddr line))) - (unless (null? l) - (set! made (cons s made)) - (when (setup-verbose-mode) - (printf "make: ~amaking ~a~a~%" - indent - s2 - (cond - ((not date) - (string-append " because " s2 " does not exist")) - ((string? reason) - (string-append " because " reason " changed")) - (else - (sprintf " just because (reason: ~a date: ~a)" - reason date)))) ) - (handle-exceptions exn - (begin - (printf "make: Failed to make ~a: ~a~%" - (car line) - (if (exn? exn) - (exn-message exn) - exn)) - (signal exn) ) - ((car l)))))))) - (unless date - (error (sprintf "(make) don't know how to make ~a" s2)))))))) - (cond - ((string? argv) (make-file argv "")) - ((null? argv) (make-file (caar spec) "")) - (else (for-each (lambda (f) (make-file f "")) argv))) - (when (setup-verbose-mode) - (for-each (lambda (item) - (printf "make: made ~a~%" item)) - (reverse made)))) ) - -(define make/proc - (case-lambda - ((spec) (make:make/proc/helper spec '())) - ((spec argv) - (make:make/proc/helper - spec - (if (vector? argv) - (vector->list argv) - argv) ) ) ) ) - -(define-syntax make - (lambda (form r c) - (##sys#check-syntax 'make form '(_ _ . #(_ 0 1))) - (let ((spec (cadr form)) - (%list (r 'list)) - (%lambda (r 'lambda))) - (let ((form-error (lambda (s . p) (apply error s spec p)))) - (and (or (list? spec) (form-error "illegal specification (not a sequence)")) - (or (pair? spec) (form-error "empty specification")) - (every - (lambda (line) - (and (or (and (list? line) (>= (length line) 2)) - (form-error "clause does not have at least 2 parts" line)) - (let ((name (car line))) - (or (list? (cadr line)) - (make:line-error "second part of clause is not a sequence" (cadr line) name))))) - spec)) - `(,(r 'make/proc) - (list ,@(map (lambda (line) - `(,%list ,(car line) - (,%list ,@(cadr line)) - ,@(let ((l (cddr line))) - (if (null? l) - '() - `((,%lambda () ,@l)))))) - spec)) - ,@(if (null? (cddr form)) - '('()) - (cddr form))))))) - -;;;^^^ -;;; DEPRECATED - - ;;; Processing setup scripts (define (make-setup-info-pathname fn #!optional (rpath (repository-path))) @@ -710,40 +540,6 @@ (ignore-errors ($system (sprintf "~A ~A" *remove-command* (shellpath fname)))) (zero? r) ) ) -(define (required-chicken-version v) ;DEPRECATED - (when (version>=? v (chicken-version) ) - (error (sprintf "CHICKEN version ~a or higher is required" v)) ) ) - -(define (upgrade-message ext msg #!optional version) - (error - (sprintf - "the currently installed extension `~s' ~a - please run~%~% chicken-install ~a~a~%~%and repeat the current installation operation." - ext msg ext (if version (conc ":" version) "")) ) ) - -(define (required-extension-version . args) ;DEPRECATED - (let loop ((args args)) - (cond ((null? args) #f) - ((and (list? args) (>= (length args) 2)) - (let* ((ext (car args)) - (version (cadr args)) - (more (cddr args)) - (info (extension-information ext))) - (if info - (let ((ver (and (assq 'version info) (cadr (assq 'version info))))) - (cond ((not ver) (upgrade-message ext "has no associated version information")) - ((and (version>=? version ver) - (not (string=? (->string version) (->string ver)))) - (upgrade-message - ext - (sprintf - "is older than ~a, which is the minimum version that this extension requires" - version) - version) ) - (else (loop more)) ) ) - (upgrade-message ext "is not installed") ) ) ) - (else - (error 'required-extension-information "bad argument format" args)) ) ) ) - (define test-compile try-compile) (define (find-library name proc) diff --git a/srfi-13.scm b/srfi-13.scm index 3dbc2ca..7b16153 100644 --- a/srfi-13.scm +++ b/srfi-13.scm @@ -150,23 +150,24 @@ . body) ) ) ) ) ) (define-syntax let-string-start+end - (lambda (form r c) - (##sys#check-syntax 'let-string-start+end form '(_ _ _ _ _ . _)) - (let ((s-e-r (cadr form)) - (proc (caddr form)) - (s-exp (cadddr form)) - (args-exp (car (cddddr form))) - (body (cdr (cddddr form))) - (%receive (r 'receive)) - (%string-parse-start+end (r 'string-parse-start+end)) - (%string-parse-final-start+end (r 'string-parse-final-start+end))) - (if (pair? (cddr s-e-r)) - `(,%receive (,(caddr s-e-r) ,(car s-e-r) ,(cadr s-e-r)) - (,%string-parse-start+end ,proc ,s-exp ,args-exp) - ,@body) - `(,%receive ,s-e-r - (,%string-parse-final-start+end ,proc ,s-exp ,args-exp) - ,@body) ) ))) + (er-macro-transformer + (lambda (form r c) + (##sys#check-syntax 'let-string-start+end form '(_ _ _ _ _ . _)) + (let ((s-e-r (cadr form)) + (proc (caddr form)) + (s-exp (cadddr form)) + (args-exp (car (cddddr form))) + (body (cdr (cddddr form))) + (%receive (r 'receive)) + (%string-parse-start+end (r 'string-parse-start+end)) + (%string-parse-final-start+end (r 'string-parse-final-start+end))) + (if (pair? (cddr s-e-r)) + `(,%receive (,(caddr s-e-r) ,(car s-e-r) ,(cadr s-e-r)) + (,%string-parse-start+end ,proc ,s-exp ,args-exp) + ,@body) + `(,%receive ,s-e-r + (,%string-parse-final-start+end ,proc ,s-exp ,args-exp) + ,@body) ) )))) ;;; Returns three values: rest start end diff --git a/srfi-69.scm b/srfi-69.scm index 9fba35e..a36ec89 100644 --- a/srfi-69.scm +++ b/srfi-69.scm @@ -125,19 +125,20 @@ (define-constant flonum-magic 331804471) (define-syntax $flonum-hash - (lambda (form r c) - (let ( (flo (cadr form)) - (_%subbyte (r '%subbyte)) - (_flonum-magic (r 'flonum-magic)) - (_fx+ (r 'fx+)) - (_fx* (r 'fx*)) - (_fxshl (r 'fxshl)) ) - `(,_fx* ,_flonum-magic - ,(let loop ( (idx (fx- (##sys#size 1.0) 1)) ) - (if (fx= 0 idx) - `(,_%subbyte ,flo 0) - `(,_fx+ (,_%subbyte ,flo ,idx) - (,_fxshl ,(loop (fx- idx 1)) 1)) ) ) ) ) ) ) + (er-macro-transformer + (lambda (form r c) + (let ( (flo (cadr form)) + (_%subbyte (r '%subbyte)) + (_flonum-magic (r 'flonum-magic)) + (_fx+ (r 'fx+)) + (_fx* (r 'fx*)) + (_fxshl (r 'fxshl)) ) + `(,_fx* ,_flonum-magic + ,(let loop ( (idx (fx- (##sys#size 1.0) 1)) ) + (if (fx= 0 idx) + `(,_%subbyte ,flo 0) + `(,_fx+ (,_%subbyte ,flo ,idx) + (,_fxshl ,(loop (fx- idx 1)) 1)) ) ) ) ) )) ) (define (##sys#number-hash-hook obj rnd) (*equal?-hash obj rnd) ) diff --git a/tests/lolevel-tests.scm b/tests/lolevel-tests.scm index 298f0a2..2a92c00 100644 --- a/tests/lolevel-tests.scm +++ b/tests/lolevel-tests.scm @@ -40,13 +40,6 @@ ; pointer->address -; null-pointer - -; null-pointer? - -(assert (null-pointer? (null-pointer))) -(assert (null-pointer? (address->pointer #x0))) - ; object->pointer ; pointer->object @@ -242,16 +235,6 @@ (assert (vector? some-bar)) -; mutate-procedure - -(assert (equal? '(1 2) (foo 1 2))) - -(define new-foo (mutate-procedure foo (lambda (new) (lambda args (cons 'hello (apply new args)))))) - -(assert (not (eq? foo new-foo))) - -(assert (equal? '(hello 1 2) (foo 1 2))) - ; pointer vectors (define pv (make-pointer-vector 42 #f)) diff --git a/tests/module-tests.scm b/tests/module-tests.scm index 928046a..6d7bd1c 100644 --- a/tests/module-tests.scm +++ b/tests/module-tests.scm @@ -281,8 +281,9 @@ (module m29 * (import chicken scheme) (define-syntax m29-baz - (lambda _ - ''foo))) + (er-macro-transformer + (lambda _ + ''foo)))) (module m30 * (import chicken scheme) diff --git a/tests/numbers-string-conversion-tests.scm b/tests/numbers-string-conversion-tests.scm index e02341d..3373117 100644 --- a/tests/numbers-string-conversion-tests.scm +++ b/tests/numbers-string-conversion-tests.scm @@ -193,14 +193,12 @@ ("#i+nan.0" the-nan "+nan.0" "+NaN.0") ("#i+inf.0" pos-inf "+inf.0" "+Inf.0") ("#i-inf.0" neg-inf "-inf.0" "-Inf.0") -#| - ;; DEPRECATED (Disabled during deprecation period of "[+-]nan", "[+-]inf") + ;; These used to be accepted but are invalid ("+nan" #f) ("+inf" #f) ("-inf" #f) ("nan.0" #f) ("inf.0" #f) -|# "Fractions" ("1/2" (/ 1 2) "0.5" ".5" "500.0e-3") diff --git a/types.db b/types.db index 205dd34..2b5a8c8 100644 --- a/types.db +++ b/types.db @@ -1168,8 +1168,6 @@ (alist-update! (#(procedure #:enforce) alist-update! (* * (list-of pair) #!optional (procedure (* *) *)) *)) (alist-update (#(procedure #:clean #:enforce) alist-update (* * (list-of pair) #!optional (procedure (* *) *) *) *)) -(always? deprecated) - (any? (#(procedure #:pure) any? (*) boolean) ((*) (let ((#(tmp) #(1))) '#t))) @@ -1205,8 +1203,6 @@ (forall (e) (#(procedure #:enforce) merge! ((list-of e) (list-of e) (procedure (e e) *)) (list-of e)))) -(never? deprecated) -(none? deprecated) (o (#(procedure #:clean #:enforce) o (#!rest (procedure (*) *)) (procedure (*) *))) (queue->list (#(procedure #:clean #:enforce) queue->list ((struct queue)) list)) (queue-add! (#(procedure #:clean #:enforce) queue-add! ((struct queue) *) undefined)) @@ -1227,7 +1223,6 @@ (rassoc (#(procedure #:clean #:enforce) rassoc (* (list-of pair) #!optional (procedure (* *) *)) *)) (reverse-string-append (#(procedure #:clean #:enforce) reverse-string-append ((list-of string)) string)) -(shuffle deprecated) (sort (forall (e (s (or (vector-of e) (list-of e)))) @@ -1448,10 +1443,6 @@ (mutate-procedure! (#(procedure #:enforce) mutate-procedure! (procedure (procedure (procedure) . *)) procedure)) -(mutate-procedure (deprecated mutate-procedure!)) -(null-pointer deprecated) -(null-pointer? deprecated) - (number-of-bytes (#(procedure #:clean) number-of-bytes (*) fixnum) (((or blob string)) (##sys#size #(1))) (((or port procedure symbol pair vector locative float pointer-vector)) @@ -1584,7 +1575,6 @@ (current-effective-group-id (#(procedure #:clean) current-effective-group-id () fixnum)) (current-effective-user-id (#(procedure #:clean) current-effective-user-id () fixnum)) (current-effective-user-name (#(procedure #:clean) current-effective-user-name () string)) -(current-environment deprecated) (get-environment-variables (#(procedure #:clean) get-environment-variables () (list-of string))) (current-group-id (#(procedure #:clean) current-group-id () fixnum)) (current-process-id (#(procedure #:clean) current-process-id () fixnum)) @@ -2267,7 +2257,6 @@ (make-condition-variable (#(procedure #:clean) make-condition-variable (#!optional *) (struct condition-variable))) (make-mutex (#(procedure #:clean) make-mutex (#!optional *) (struct mutex))) (make-thread (#(procedure #:clean #:enforce) make-thread ((procedure () . *) #!optional *) (struct thread))) -(milliseconds->time deprecated) (mutex-lock! (#(procedure #:clean #:enforce) mutex-lock! ((struct mutex) #!optional * (struct thread)) boolean)) (mutex-name (#(procedure #:clean #:enforce) mutex-name ((struct mutex)) *) @@ -2318,7 +2307,6 @@ (thread? (#(procedure #:pure #:predicate (struct thread)) thread? (*) boolean)) -(time->milliseconds deprecated) (time->seconds (#(procedure #:clean #:enforce) time->seconds ((struct time)) number)) (time? (#(procedure #:pure #:predicate (struct time)) time? (*) boolean)) @@ -2576,8 +2564,6 @@ ;; utils -(for-each-argv-line deprecated) -(for-each-line deprecated) (read-all (#(procedure #:enforce) read-all (#!optional (or input-port string)) string)) (system* (#(procedure #:clean #:enforce) system* (string #!rest) undefined)) (qs (#(procedure #:clean #:enforce) qs (string) string)) -- 1.7.9.1