Also make reverse* an alias for append-reverse.
(loop set))
\f
;;; 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)
parameters
(let ((n-parameters (length parameters)))
(if (> (length arguments) n-parameters)
- (list-head arguments n-parameters)
+ (take arguments n-parameters)
arguments)))))
'())))
\f
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
(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)
(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
(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))))
(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)
(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)))))))))
\f
(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
(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)
(let ()
(let ((end (- nv total)))
(do ((versions
- (list-tail
+ (drop
(sort (cdr file)
(lambda (x y)
(< (car x) (car y))))
(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)))
'()
(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)))
(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)))))))
\f
;;;; Marks
(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)
(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)
(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)
(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
(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)))))
(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)))
(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)
(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)
(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))
(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
(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)))))))
\f
(define (parse-mime-body:extensions tail)
(if (pair? tail)
(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)))
(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)
(- (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))
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)))))
\f
(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!)
(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))))
#t))
\f
(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))))
(lambda () '())
(lambda (l) l)
%append-2))
-\f
+
(define (%append-2! l1 l2)
(if (pair? l1)
(begin (set-cdr! (last-pair l1) l2)
(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))))
\f
;;;; Mapping Procedures
(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)
(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))
(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 ()
(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)
(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)
(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)
fold-left
keep-matching-items
keep-matching-items!
- list-head
map*
reduce-left)
(export ()
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
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
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
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!
(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!
partition!
remove
remove!
+ reverse
+ reverse!
span
span!
split-at
(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))
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!)
(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)))
(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))
#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))
(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))))))))
\f
(define (apply-generic-1 record)
(lambda (a1)
(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
(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))))
(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)))
(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
(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"))
projects / mit-scheme.git / commitdiff