From: Chris Hanson Date: Thu, 5 Dec 2019 00:21:06 +0000 (-0800) Subject: Eliminate use of list-head and list-tail. X-Git-Tag: mit-scheme-pucked-10.1.20~10^2~6 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=d6b8dd2094d60880985c39b4d263f6ca1497f3bd;p=mit-scheme.git Eliminate use of list-head and list-tail. Also make reverse* an alias for append-reverse. --- diff --git a/src/compiler/base/sets.scm b/src/compiler/base/sets.scm index 236648c75..41e3fed8c 100644 --- a/src/compiler/base/sets.scm +++ b/src/compiler/base/sets.scm @@ -74,7 +74,7 @@ USA. (loop set)) ;;; The dataflow analyzer assumes that -;;; (eq? (list-tail (eq-set-union x y) n) y) for some n. +;;; (eq? (drop (eq-set-union x y) n) y) for some n. (define (eq-set-union x y) (if (null? y) diff --git a/src/compiler/fgopt/order.scm b/src/compiler/fgopt/order.scm index 8e3c7bb4b..d4d1051ad 100644 --- a/src/compiler/fgopt/order.scm +++ b/src/compiler/fgopt/order.scm @@ -263,7 +263,7 @@ USA. parameters (let ((n-parameters (length parameters))) (if (> (length arguments) n-parameters) - (list-head arguments n-parameters) + (take arguments n-parameters) arguments))))) '()))) diff --git a/src/compiler/fgopt/reuse.scm b/src/compiler/fgopt/reuse.scm index a99ce8c9c..095a43649 100644 --- a/src/compiler/fgopt/reuse.scm +++ b/src/compiler/fgopt/reuse.scm @@ -132,8 +132,8 @@ USA. overwritten-block) subproblems)))))) (if (< n-targets n-subproblems) - (values (make-nodes (list-head subproblems n-targets)) - (list-tail subproblems n-targets)) + (values (make-nodes (take subproblems n-targets)) + (drop subproblems n-targets)) (values (make-nodes subproblems) '())))))) (lambda (nodes extra-subproblems) (call-with-values @@ -157,7 +157,7 @@ USA. (append! (block-layout block) (loop (block-parent block))))))) (let ((n-items (length stack-layout))) (if (< overwriting-size n-items) - (list-tail stack-layout (- n-items overwriting-size)) + (drop stack-layout (- n-items overwriting-size)) stack-layout)))) (define (block-layout block) diff --git a/src/compiler/fgopt/simapp.scm b/src/compiler/fgopt/simapp.scm index a0c23eaf8..661cb8daf 100644 --- a/src/compiler/fgopt/simapp.scm +++ b/src/compiler/fgopt/simapp.scm @@ -68,7 +68,7 @@ USA. (let ((new (lvalue-values-cache (reference-lvalue operator)))) (let loop ((operators new)) ;; We can use `eq?' here because we assume that - ;; (eq? (list-tail (eq-set-union x y) n) y) for some n. + ;; (eq? (drop (eq-set-union x y) n) y) for some n. ;; This is also noted at the definition of `eq-set-union'. (if (eq? operators old) new diff --git a/src/compiler/machines/svm/assembler-compiler.scm b/src/compiler/machines/svm/assembler-compiler.scm index 6c49e4a91..39224c90f 100644 --- a/src/compiler/machines/svm/assembler-compiler.scm +++ b/src/compiler/machines/svm/assembler-compiler.scm @@ -604,7 +604,7 @@ USA. (car names) (cdr names))))) (for-each (lambda (defn name) - (set-defn-name! defn (cons (car name) (list-tail name n)))) + (set-defn-name! defn (cons (car name) (drop name n)))) defns names)))) diff --git a/src/compiler/machines/x86-64/insmac.scm b/src/compiler/machines/x86-64/insmac.scm index 7f835bc74..1de4fefac 100644 --- a/src/compiler/machines/x86-64/insmac.scm +++ b/src/compiler/machines/x86-64/insmac.scm @@ -60,7 +60,7 @@ USA. (rex (list-ref actions 1)) (mode (list-ref actions 2)) (r/m (list-ref actions 3)) - (extra (list-tail actions 4))) + (extra (drop actions 4))) `(,(close-syntax 'MAKE-EFFECTIVE-ADDRESS environment) (,(close-syntax 'QUOTE environment) ,keyword) ,(parse-categories categories environment pattern) diff --git a/src/compiler/rtlbase/rtlcon.scm b/src/compiler/rtlbase/rtlcon.scm index 0f830f3f8..635215354 100644 --- a/src/compiler/rtlbase/rtlcon.scm +++ b/src/compiler/rtlbase/rtlcon.scm @@ -583,9 +583,9 @@ USA. (do-chunk elements offset (finish)) - (do-chunk (list-head elements chunk-size) + (do-chunk (take elements chunk-size) offset - (process (list-tail elements chunk-size) + (process (drop elements chunk-size) (+ offset chunk-size) (1+ chunk))))))))) diff --git a/src/edwin/artdebug.scm b/src/edwin/artdebug.scm index fe5eb4649..4dcaab45f 100644 --- a/src/edwin/artdebug.scm +++ b/src/edwin/artdebug.scm @@ -1241,8 +1241,8 @@ Prefix argument means do not kill the debugger buffer." (delta (- subproblem-number (dstate/subproblem-number dstate)))) (if (negative? delta) (let ((subproblems - (list-tail (dstate/previous-subproblems dstate) - (-1+ (- delta))))) + (drop (dstate/previous-subproblems dstate) + (-1+ (- delta))))) (set-current-subproblem! dstate (car subproblems) (cdr subproblems)) (finish-move-to-subproblem! dstate)) (let loop diff --git a/src/edwin/debug.scm b/src/edwin/debug.scm index 76c1ff1dd..507c7fc05 100644 --- a/src/edwin/debug.scm +++ b/src/edwin/debug.scm @@ -1554,7 +1554,7 @@ once it has been renamed, it will not be deleted automatically.") (write-string " bindings (first " port) (write limit port) (write-string " shown):" port) - (finish (list-head names limit)) + (finish (take names limit)) #t))))))) (else (write-string " BINDINGS:" port) diff --git a/src/edwin/dired.scm b/src/edwin/dired.scm index 52031a648..922acc1ed 100644 --- a/src/edwin/dired.scm +++ b/src/edwin/dired.scm @@ -391,7 +391,7 @@ negative numeric arg overrides kept-old-versions with minus the arg." (let () (let ((end (- nv total))) (do ((versions - (list-tail + (drop (sort (cdr file) (lambda (x y) (< (car x) (car y)))) diff --git a/src/edwin/keymap.scm b/src/edwin/keymap.scm index f3a588a96..774a6a16c 100644 --- a/src/edwin/keymap.scm +++ b/src/edwin/keymap.scm @@ -127,7 +127,7 @@ Previous contents of that buffer are killed first." (loop (cddr elements))))))))) (define (reorder-list items) - (let ((tail (list-tail items (integer-ceiling (length items) 2)))) + (let ((tail (drop items (integer-ceiling (length items) 2)))) (let loop ((items items) (items* tail)) (cond ((eq? items tail) '()) ((null? items*) (list (car items))) diff --git a/src/edwin/kilcom.scm b/src/edwin/kilcom.scm index 30f547562..e64d38b9e 100644 --- a/src/edwin/kilcom.scm +++ b/src/edwin/kilcom.scm @@ -231,7 +231,7 @@ The command \\[yank] can retrieve it from there. '() (let ((strings (cons string kill-ring))) (if (> (length strings) kill-ring-max) - (set-cdr! (list-tail strings (- kill-ring-max 1)) '())) + (set-cdr! (drop strings (- kill-ring-max 1)) '())) strings))))) (set-variable! kill-ring strings context) (set-variable! kill-ring-yank-pointer strings context))) @@ -320,15 +320,15 @@ comes the newest one." (editor-error "Kill ring is empty")) (set-variable! kill-ring-yank-pointer - (list-tail kill-ring - (modulo (+ argument - (let ((kill-ring-yank-pointer - (ref-variable kill-ring-yank-pointer))) - (let loop ((l kill-ring) (n 0)) - (cond ((null? l) 0) - ((eq? l kill-ring-yank-pointer) n) - (else (loop (cdr l) (+ n 1))))))) - (length kill-ring))))))) + (drop kill-ring + (modulo (+ argument + (let ((kill-ring-yank-pointer + (ref-variable kill-ring-yank-pointer))) + (let loop ((l kill-ring) (n 0)) + (cond ((null? l) 0) + ((eq? l kill-ring-yank-pointer) n) + (else (loop (cdr l) (+ n 1))))))) + (length kill-ring))))))) ;;;; Marks diff --git a/src/edwin/nntp.scm b/src/edwin/nntp.scm index 44621943e..fdb81adcb 100644 --- a/src/edwin/nntp.scm +++ b/src/edwin/nntp.scm @@ -1004,7 +1004,7 @@ USA. (message msg "done") (reverse! replies)) (let* ((rxd (min rxn n-chunk)) - (rxlist* (list-tail rxlist rxd)) + (rxlist* (drop rxlist rxd)) (replies (receive-replies rxlist rxlist* replies)) (txd (min txn n-chunk))) (loop (- txn txd) diff --git a/src/edwin/prompt.scm b/src/edwin/prompt.scm index 8035ccc8e..c0c31ed2f 100644 --- a/src/edwin/prompt.scm +++ b/src/edwin/prompt.scm @@ -951,7 +951,7 @@ With argument, skips forward that many items in the history." (cond ((< index 0) 0) ((>= index hl) (- hl 1)) (else index))))) - (set-car! (list-tail *history-items* *history-index*) + (set-car! (drop *history-items* *history-index*) (typein-string)) (set! *history-index* index) (set-typein-string! (list-ref *history-items* *history-index*) #t) diff --git a/src/edwin/rfc822.scm b/src/edwin/rfc822.scm index 459690edd..67e132e7e 100644 --- a/src/edwin/rfc822.scm +++ b/src/edwin/rfc822.scm @@ -558,7 +558,7 @@ USA. (define (reverse-list->string list start end) (let* ((length (fix:- end start)) (string (make-string length))) - (let loop ((list (list-tail list start)) + (let loop ((list (drop list start)) (index length)) (cond ((fix:zero? index) string) diff --git a/src/edwin/shell.scm b/src/edwin/shell.scm index 0f3aec06a..0cc9e6fee 100644 --- a/src/edwin/shell.scm +++ b/src/edwin/shell.scm @@ -204,9 +204,8 @@ Otherwise, one argument `-i' is passed to the shell." (message "Directory stack not that deep") (let ((dirstack (let ((dirstack (cons default-directory dirstack))) - (append (list-tail dirstack num) - (list-head dirstack - (- (length dirstack) num)))))) + (append (drop dirstack num) + (take dirstack (- (length dirstack) num)))))) (set-variable! shell-dirstack (cdr dirstack)) (shell-process-cd (car dirstack)))) (begin @@ -230,7 +229,7 @@ Otherwise, one argument `-i' is passed to the shell." (else (if (= num 1) (set-variable! shell-dirstack (cdr dirstack)) - (let ((pair (list-tail dirstack (- num 1)))) + (let ((pair (drop dirstack (- num 1)))) (set-cdr! pair (cddr pair)))) (shell-dirstack-message))))) diff --git a/src/edwin/snr.scm b/src/edwin/snr.scm index d7b0235cd..39725a838 100644 --- a/src/edwin/snr.scm +++ b/src/edwin/snr.scm @@ -4200,8 +4200,8 @@ With prefix arg, replaces the file with the list information." (if limit (let ((lns (length ns))) (cond ((<= lns (abs limit)) ns) - ((< limit 0) (list-head ns (- limit))) - (else (list-tail ns (- (length ns) limit))))) + ((< limit 0) (take ns (- limit))) + (else (drop ns (- (length ns) limit))))) ns))) (let ((ignore-header? (let ((filter (ref-variable news-header-filter context))) diff --git a/src/etc/ucd-converter.scm b/src/etc/ucd-converter.scm index 449b1fb23..bd0189149 100644 --- a/src/etc/ucd-converter.scm +++ b/src/etc/ucd-converter.scm @@ -1075,8 +1075,8 @@ USA. (let loop ((values values) (n (length values))) (if (<= n 100) (list `(,make-table ,@values)) - (cons `(,make-table ,@(list-head values 100)) - (loop (list-tail values 100) + (cons `(,make-table ,@(take values 100)) + (loop (drop values 100) (- n 100))))))) (if (= 1 (length tables)) (car tables) @@ -1142,8 +1142,8 @@ USA. (let loop ((items items)) (lambda () (if (pair? items) - (cons (list-head items step) - (loop (list-tail items step))) + (cons (take items step) + (loop (drop items step))) '())))) (define (slice-prop-alist alist step) diff --git a/src/imail/imail-imap.scm b/src/imail/imail-imap.scm index 5aafa5385..86e0da6cd 100644 --- a/src/imail/imail-imap.scm +++ b/src/imail/imail-imap.scm @@ -1615,7 +1615,7 @@ USA. (intern (list-ref body 5)) (list-ref body 6) (list-ref body 7) - (parse-mime-body:extensions (list-tail body 8)))) + (parse-mime-body:extensions (drop body 8)))) ((and (string-ci=? "message" (car body)) (string-ci=? "rfc822" (cadr body))) (if (not (fix:>= n 10)) @@ -1632,7 +1632,7 @@ USA. (parse-mime-envelope (list-ref body 7)) enclosed (list-ref body 9) - (parse-mime-body:extensions (list-tail body 10))))) + (parse-mime-body:extensions (drop body 10))))) (set-mime-body-enclosure! enclosed enclosure) enclosure)) (else @@ -1646,7 +1646,7 @@ USA. (list-ref body 4) (intern (list-ref body 5)) (list-ref body 6) - (parse-mime-body:extensions (list-tail body 7))))))) + (parse-mime-body:extensions (drop body 7))))))) (define (parse-mime-body:extensions tail) (if (pair? tail) diff --git a/src/runtime/advice.scm b/src/runtime/advice.scm index f790d6c5f..e9dbfd0bb 100644 --- a/src/runtime/advice.scm +++ b/src/runtime/advice.scm @@ -287,7 +287,7 @@ USA. (write-args arguments) (write-string "]" port)) (begin - (write-args (list-head arguments 10)) + (write-args (take arguments 10)) (newline port) (write-string " ...]" port)))))) (newline port))) diff --git a/src/runtime/dbgutl.scm b/src/runtime/dbgutl.scm index 3677cb15d..12d1ec503 100644 --- a/src/runtime/dbgutl.scm +++ b/src/runtime/dbgutl.scm @@ -153,7 +153,7 @@ USA. (write brief-bindings-limit port) (write-string " shown):" port) (newline port) - (finish (list-head bindings brief-bindings-limit))) + (finish (take bindings brief-bindings-limit))) (else (write-string " has bindings:" port) (newline port) diff --git a/src/runtime/debug.scm b/src/runtime/debug.scm index 8e3b773ce..4e74780a1 100644 --- a/src/runtime/debug.scm +++ b/src/runtime/debug.scm @@ -537,7 +537,7 @@ USA. (- (prompt-for-nonnegative-integer "Subproblem number" false port) (dstate/subproblem-number dstate)))) (if (negative? delta) - (list-tail (dstate/previous-subproblems dstate) (-1+ (- delta))) + (drop (dstate/previous-subproblems dstate) (-1+ (- delta))) (let loop ((subproblem (dstate/subproblem dstate)) (subproblems (dstate/previous-subproblems dstate)) diff --git a/src/runtime/defstr.scm b/src/runtime/defstr.scm index ff61806a1..706560a71 100644 --- a/src/runtime/defstr.scm +++ b/src/runtime/defstr.scm @@ -654,8 +654,8 @@ differences: value)) ((list) `(,(absolute 'set-car! context) - (,(absolute 'list-tail context) structure - ,(slot/index slot)) + (,(absolute 'drop context) structure + ,(slot/index slot)) value))))))) (remove slot/read-only? (structure/slots structure))))) diff --git a/src/runtime/gcstat.scm b/src/runtime/gcstat.scm index 403c897e6..f942b2d08 100644 --- a/src/runtime/gcstat.scm +++ b/src/runtime/gcstat.scm @@ -187,8 +187,8 @@ USA. (define (copy-to-size l size) (let ((max (length l))) (if (>= max size) - (list-head l size) - (append (list-head l max) + (take l size) + (append (take l max) (make-list (- size max) '()))))) (define (bounded:install-history!) diff --git a/src/runtime/infutl.scm b/src/runtime/infutl.scm index 65f2a425c..0a269081a 100644 --- a/src/runtime/infutl.scm +++ b/src/runtime/infutl.scm @@ -249,8 +249,8 @@ USA. (pathname-new-directory (file-pathname pathname) (cons 'relative - (list-tail (pathname-directory pathname) - (length (pathname-directory (car rule)))))) + (drop (pathname-directory pathname) + (length (pathname-directory (car rule)))))) (cdr rule)) pathname)))) diff --git a/src/runtime/list.scm b/src/runtime/list.scm index 9e873f274..a1a8e7678 100644 --- a/src/runtime/list.scm +++ b/src/runtime/list.scm @@ -321,39 +321,13 @@ USA. #t)) (define (list-ref list index) - (let ((tail (list-tail list index))) - (if (not (pair? tail)) - (error:bad-range-argument index 'list-ref)) - (car tail))) + (car (drop list index))) (define (list-set! list index new-value) - (let ((tail (list-tail list index))) - (if (not (pair? tail)) - (error:bad-range-argument index 'list-set!)) - (set-car! tail new-value))) - -(define (list-tail list index) - (guarantee index-fixnum? index 'list-tail) - (let loop ((list list) (index* index)) - (if (fix:zero? index*) - list - (begin - (if (not (pair? list)) - (error:bad-range-argument index 'list-tail)) - (loop (cdr list) (fix:- index* 1)))))) - -(define (list-head list index) - (guarantee index-fixnum? index 'list-head) - (let loop ((list list) (index* index)) - (if (fix:zero? index*) - '() - (begin - (if (not (pair? list)) - (error:bad-range-argument index 'list-head)) - (cons (car list) (loop (cdr list) (fix:- index* 1))))))) + (set-car! (drop list index) new-value)) (define (sublist list start end) - (list-head (list-tail list start) (- end start))) + (take (drop list start) (- end start))) (define (list-copy items) (let ((lose (lambda () (error:not-a list? items 'list-copy)))) @@ -573,7 +547,7 @@ USA. (lambda () '()) (lambda (l) l) %append-2)) - + (define (%append-2! l1 l2) (if (pair? l1) (begin (set-cdr! (last-pair l1) l2) @@ -597,29 +571,6 @@ USA. (lambda () '()) (lambda (l) l) %append-2!)) - -(define (reverse l) (reverse* l '())) -(define (reverse! l) (reverse*! l '())) - -(define (reverse* l tail) - (let loop ((rest l) (so-far tail)) - (if (pair? rest) - (loop (cdr rest) (cons (car rest) so-far)) - (begin - (if (not (null? rest)) - (error:not-a list? l 'reverse*)) - so-far)))) - -(define (reverse*! l tail) - (let loop ((current l) (new-cdr tail)) - (if (pair? current) - (let ((next (cdr current))) - (set-cdr! current new-cdr) - (loop next current)) - (begin - (if (not (null? current)) - (error:not-a list? l 'reverse*!)) - new-cdr)))) ;;;; Mapping Procedures diff --git a/src/runtime/load.scm b/src/runtime/load.scm index b4be85cc4..8a246f0b4 100644 --- a/src/runtime/load.scm +++ b/src/runtime/load.scm @@ -437,7 +437,7 @@ USA. (define (standard-uri->pathname uri) (or (uri->pathname uri #f) (merge-pathnames - (uri->pathname (make-uri #f #f (list-tail (uri-path uri) 4) #f #f)) + (uri->pathname (make-uri #f #f (drop (uri-path uri) 4) #f #f)) (standard-library-directory-pathname)))) (define (system-uri #!optional rel-uri) diff --git a/src/runtime/mit-macros.scm b/src/runtime/mit-macros.scm index 3082ae9cf..8b455b1e7 100644 --- a/src/runtime/mit-macros.scm +++ b/src/runtime/mit-macros.scm @@ -594,15 +594,15 @@ USA. (define (choose i) (let ((choice (assv i choices)) - (args* (list-head args i))) + (args* (take args i))) (if choice (apply scons-call (cdr choice) args*) (scons-call 'error "No matching case-lambda clause:" (apply scons-call 'list args*))))) - (scons-lambda (append (list-head args low) + (scons-lambda (append (take args low) (list #!optional) - (list-tail args low)) + (drop args low)) (let loop ((i low)) (if (fix:< i high) (scons-if (scons-call 'default-object? (list-ref args i)) diff --git a/src/runtime/output-port.scm b/src/runtime/output-port.scm index 6c9d4c0b8..71bc891a2 100644 --- a/src/runtime/output-port.scm +++ b/src/runtime/output-port.scm @@ -231,9 +231,9 @@ USA. (n-strings (length strings)) (cols '())) (if (> n-strings n-rows) - (loop (list-tail strings n-rows) + (loop (drop strings n-rows) (- n-strings n-rows) - (cons (list-head strings n-rows) cols)) + (cons (take strings n-rows) cols)) (reverse! (if (> n-strings 0) (cons strings cols) cols))))) (lambda () diff --git a/src/runtime/pp.scm b/src/runtime/pp.scm index 3358094f1..807f6150a 100644 --- a/src/runtime/pp.scm +++ b/src/runtime/pp.scm @@ -504,7 +504,7 @@ USA. (and (>= available-space (+ (-1+ n-cols) (reduce + 0 widths))) (let ((last-n-1 (remainder (-1+ n-nodes) n-cols))) (>= available-space - (+ (+ last-n-1 (reduce + 0 (list-head widths last-n-1))) + (+ (+ last-n-1 (reduce + 0 (take widths last-n-1))) (+ last-size depth)))))) (define (find-max-width posn step) diff --git a/src/runtime/record.scm b/src/runtime/record.scm index bd4035383..0de2d8af4 100644 --- a/src/runtime/record.scm +++ b/src/runtime/record.scm @@ -905,10 +905,10 @@ USA. (if (structure-type/tag type) (lambda (structure value) (check-list-tagged structure type) - (set-car! (list-tail structure index) value)) + (set-car! (drop structure index) value)) (lambda (structure value) (check-list-untagged structure type) - (set-car! (list-tail structure index) value))))) + (set-car! (drop structure index) value))))) (define-integrable (check-vector-tagged structure type) (if (not (and (vector? structure) diff --git a/src/runtime/rep.scm b/src/runtime/rep.scm index da9b09f5b..9364e399c 100644 --- a/src/runtime/rep.scm +++ b/src/runtime/rep.scm @@ -771,7 +771,7 @@ USA. (define (repl-history/replace-current! history object) (let ((elements (repl-history/elements history))) (if (pair? elements) - (set-car! (list-tail elements (- (repl-history/size history) 1)) + (set-car! (drop elements (- (repl-history/size history) 1)) object)))) (define (repl-history/read history n) diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg index 3b20ee38f..7108745c9 100644 --- a/src/runtime/runtime.pkg +++ b/src/runtime/runtime.pkg @@ -3175,7 +3175,6 @@ USA. fold-left keep-matching-items keep-matching-items! - list-head map* reduce-left) (export () @@ -3190,48 +3189,48 @@ USA. alist-delete! ;SRFI-1 alist? any-duplicates? - append + append ;SRFI-1 append! ;SRFI-1 append-map ;SRFI-1 append-map! ;SRFI-1 - assoc + assoc ;SRFI-1 association-procedure - assq - assv - caaaar - caaadr - caaar - caadar - caaddr - caadr - caar - cadaar - cadadr - cadar - caddar - cadddr - caddr - cadr - car + assq ;SRFI-1 + assv ;SRFI-1 + caaaar ;SRFI-1 + caaadr ;SRFI-1 + caaar ;SRFI-1 + caadar ;SRFI-1 + caaddr ;SRFI-1 + caadr ;SRFI-1 + caar ;SRFI-1 + cadaar ;SRFI-1 + cadadr ;SRFI-1 + cadar ;SRFI-1 + caddar ;SRFI-1 + cadddr ;SRFI-1 + caddr ;SRFI-1 + cadr ;SRFI-1 + car ;SRFI-1 car+cdr ;SRFI-1 - cdaaar - cdaadr - cdaar - cdadar - cdaddr - cdadr - cdar - cddaar - cddadr - cddar - cdddar - cddddr - cdddr - cddr - cdr + cdaaar ;SRFI-1 + cdaadr ;SRFI-1 + cdaar ;SRFI-1 + cdadar ;SRFI-1 + cdaddr ;SRFI-1 + cdadr ;SRFI-1 + cdar ;SRFI-1 + cddaar ;SRFI-1 + cddadr ;SRFI-1 + cddar ;SRFI-1 + cdddar ;SRFI-1 + cddddr ;SRFI-1 + cdddr ;SRFI-1 + cddr ;SRFI-1 + cdr ;SRFI-1 circular-list ;SRFI-1 circular-list? ;SRFI-1 - cons + cons ;SRFI-1 cons* ;SRFI-1 decode-general-car-cdr del-assoc @@ -3249,17 +3248,17 @@ USA. delv delv! dotted-list? ;SRFI-1 - eighth + eighth ;SRFI-1 encode-general-car-cdr error:not-restricted-keyword-list except-last-pair except-last-pair! - fifth - first + fifth ;SRFI-1 + first ;SRFI-1 fold ;SRFI-1 fold-right ;SRFI-1 - for-each - fourth + for-each ;SRFI-1 + fourth ;SRFI-1 general-car-cdr get-keyword-value get-keyword-values @@ -3273,9 +3272,9 @@ USA. keyword-option-parser last ;SRFI-1 last-pair ;SRFI-1 - length + length ;SRFI-1 length=? - list + list ;SRFI-1 list->weak-list list-copy ;SRFI-1 list-deletor @@ -3283,41 +3282,36 @@ USA. list-of-type? list-of-type?->length list-of-unique-symbols? - list-ref + list-ref ;SRFI-1 list-set! - list-tail ;use SRFI-1 drop list= ;SRFI-1 list? list?->length make-circular-list make-initialized-list make-list ;SRFI-1 - map - member + map ;SRFI-1 + member ;SRFI-1 member-procedure - memq - memv - ninth + memq ;SRFI-1 + memv ;SRFI-1 + ninth ;SRFI-1 non-empty-list? not-pair? ;SRFI-1 null-list? ;SRFI-1 - null? - pair? + null? ;SRFI-1 + pair? ;SRFI-1 reduce ;SRFI-1 reduce-right ;SRFI-1 restricted-keyword-list? - reverse - reverse! ;SRFI-1 - reverse* - reverse*! - second - set-car! - set-cdr! - seventh - sixth + second ;SRFI-1 + set-car! ;SRFI-1 + set-cdr! ;SRFI-1 + seventh ;SRFI-1 + sixth ;SRFI-1 sublist - tenth - third + tenth ;SRFI-1 + third ;SRFI-1 tree-copy ;SRFI-1 unique-keyword-list? weak-delq! @@ -3351,9 +3345,13 @@ USA. (files "srfi-1") (parent (runtime)) (export deprecated () + (list-head take) + (reverse* append-reverse) + (reverse*! append-reverse!) for-all? there-exists?) (export () + (list-tail drop) any append-reverse append-reverse! @@ -3399,6 +3397,8 @@ USA. partition! remove remove! + reverse + reverse! span span! split-at diff --git a/src/runtime/scan.scm b/src/runtime/scan.scm index ac550476d..96f065a59 100644 --- a/src/runtime/scan.scm +++ b/src/runtime/scan.scm @@ -191,8 +191,8 @@ USA. (define (%open-block-actions open-block) (make-scode-sequence - (list-tail (cdr (scode-sequence-actions open-block)) - (length (%open-block-names open-block))))) + (drop (cdr (scode-sequence-actions open-block)) + (length (%open-block-names open-block))))) (define-integrable (make-open-block-descriptor names declarations) (vector open-block-tag names declarations)) diff --git a/src/runtime/srfi-1.scm b/src/runtime/srfi-1.scm index 0a0771195..c9ad9ab87 100644 --- a/src/runtime/srfi-1.scm +++ b/src/runtime/srfi-1.scm @@ -340,12 +340,18 @@ USA. len)) len))) +(define (reverse l) + (append-reverse l '())) + (define (append-reverse rev-head tail) (let lp ((rev-head rev-head) (tail tail)) (if (null-list? rev-head 'append-reverse) tail (lp (cdr rev-head) (cons (car rev-head) tail))))) +(define (reverse! l) + (append-reverse! l '())) + (define (append-reverse! rev-head tail) (let lp ((rev-head rev-head) (tail tail)) (if (null-list? rev-head 'append-reverse!) diff --git a/src/runtime/string.scm b/src/runtime/string.scm index cac40cd9f..cabf6234b 100644 --- a/src/runtime/string.scm +++ b/src/runtime/string.scm @@ -1387,7 +1387,7 @@ USA. (n (fix:- end start)) (builder (string-builder n))) (do ((i 0 (fix:+ i 1)) - (chars (list-tail chars start) (cdr chars))) + (chars (drop chars start) (cdr chars))) ((not (fix:< i n))) (guarantee char? (car chars) 'list->string) (builder (car chars))) diff --git a/src/runtime/unix-pathname.scm b/src/runtime/unix-pathname.scm index 143f4296d..0d2b226de 100644 --- a/src/runtime/unix-pathname.scm +++ b/src/runtime/unix-pathname.scm @@ -317,7 +317,7 @@ USA. (if (pair? (pathname-directory pathname)) (let loop ((pathname pathname) (np 1)) (let ((directory (pathname-directory pathname))) - (let scan ((p (list-tail directory np)) (np np)) + (let scan ((p (drop directory np)) (np np)) (if (pair? p) (cond ((and (not (eq? (car p) 'up)) (pair? (cdr p)) diff --git a/src/sf/reduct.scm b/src/sf/reduct.scm index fa907ea89..318539145 100644 --- a/src/sf/reduct.scm +++ b/src/sf/reduct.scm @@ -319,8 +319,8 @@ Examples: #f (reassign expr - (let ((l1 (list-head operands spare-args)) - (l2 (map2 (list-tail operands spare-args)))) + (let ((l1 (take operands spare-args)) + (l2 (map2 (drop operands spare-args)))) (cond ((null? l2) (wrap block l1 (none block))) ((null? (cdr l2)) diff --git a/src/sos/generic.scm b/src/sos/generic.scm index 1fee65eae..4d1646aea 100644 --- a/src/sos/generic.scm +++ b/src/sos/generic.scm @@ -220,7 +220,7 @@ USA. (and (fix:> n-args arity-min) (or (not arity-max) (fix:<= n-args arity-max)) - (generator procedure (list-head tags arity-min)))))))) + (generator procedure (take tags arity-min)))))))) (define (apply-generic-1 record) (lambda (a1) diff --git a/tests/runtime/test-floenv.scm b/tests/runtime/test-floenv.scm index d00b64ad1..4ad88bc19 100644 --- a/tests/runtime/test-floenv.scm +++ b/tests/runtime/test-floenv.scm @@ -193,7 +193,7 @@ USA. (cond ((assq elicitor-name elicitors) => (lambda (pair) (set-cdr! pair procedure))) (else - (set-car! (list-tail descriptor 4) + (set-car! (drop descriptor 4) (cons (cons elicitor-name procedure) elicitors))))))) (else diff --git a/tests/runtime/test-string.scm b/tests/runtime/test-string.scm index 422518918..0abab4610 100644 --- a/tests/runtime/test-string.scm +++ b/tests/runtime/test-string.scm @@ -105,7 +105,7 @@ USA. (let ((end (length latin-alphabet))) (do ((i 0 (fix:+ i 1))) ((not (fix:< i end))) - (let ((chars (list-head latin-alphabet i))) + (let ((chars (take latin-alphabet i))) (let ((result (build-string chars))) (assert-true (legacy-string? result)) (assert-string= result (chars->string chars)))) @@ -120,7 +120,7 @@ USA. (let ((end (length greek-alphabet))) (do ((i 0 (fix:+ i 1))) ((not (fix:< i end))) - (let ((chars (list-head greek-alphabet i))) + (let ((chars (take greek-alphabet i))) (assert-string= (build-string chars) (chars->string chars))) (let ((strings (make-test-strings i greek-alphabet #f))) @@ -161,7 +161,7 @@ USA. (let loop ((k 0) (strings '())) (if (fix:< k n) (loop (fix:+ k 1) - (cons (chars->string (list-head alphabet k)) + (cons (chars->string (take alphabet k)) strings)) (if reverse? strings @@ -233,9 +233,9 @@ USA. (list->string (let ((l1 (string->list s1)) (l2 (string->list s2 start end))) - (append (list-head l1 at) + (append (take l1 at) l2 - (list-tail l1 (+ at (length l2))))))) + (drop l1 (+ at (length l2))))))) (define-test 'string-slice (let ((s "abcdefghijklmnopqrstuvwxyz"))