This repository has been archived on 2022-08-10. You can view files and clone it, but cannot push or open issues or pull requests.
chez-openbsd/s/5_2.ss
2022-07-29 15:12:07 +02:00

796 lines
26 KiB
Scheme

;;; 5_2.ss
;;; Copyright 1984-2017 Cisco Systems, Inc.
;;;
;;; Licensed under the Apache License, Version 2.0 (the "License");
;;; you may not use this file except in compliance with the License.
;;; You may obtain a copy of the License at
;;;
;;; http://www.apache.org/licenses/LICENSE-2.0
;;;
;;; Unless required by applicable law or agreed to in writing, software
;;; distributed under the License is distributed on an "AS IS" BASIS,
;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
;;; See the License for the specific language governing permissions and
;;; limitations under the License.
;;; list and pair functions
(begin
(define atom?
(lambda (x)
(not (pair? x))))
(define list?
(lambda (x)
(let loop ([hare x] [tortoise x])
(if (pair? hare)
(let ([hare (cdr hare)])
(if (pair? hare)
(and (not (eq? hare tortoise))
(loop (cdr hare) (cdr tortoise)))
(null? hare)))
(null? hare)))))
(define null?
(lambda (x)
(eq? x '())))
(define caar (lambda (x) (#2%caar x)))
(define cadr (lambda (x) (#2%cadr x)))
(define cdar (lambda (x) (#2%cdar x)))
(define cddr (lambda (x) (#2%cddr x)))
(define caaar (lambda (x) (#2%caaar x)))
(define caadr (lambda (x) (#2%caadr x)))
(define cadar (lambda (x) (#2%cadar x)))
(define caddr (lambda (x) (#2%caddr x)))
(define cdaar (lambda (x) (#2%cdaar x)))
(define cdadr (lambda (x) (#2%cdadr x)))
(define cddar (lambda (x) (#2%cddar x)))
(define cdddr (lambda (x) (#2%cdddr x)))
(define caaaar (lambda (x) (#2%caaaar x)))
(define caaadr (lambda (x) (#2%caaadr x)))
(define caadar (lambda (x) (#2%caadar x)))
(define caaddr (lambda (x) (#2%caaddr x)))
(define cadaar (lambda (x) (#2%cadaar x)))
(define cadadr (lambda (x) (#2%cadadr x)))
(define caddar (lambda (x) (#2%caddar x)))
(define cadddr (lambda (x) (#2%cadddr x)))
(define cdaaar (lambda (x) (#2%cdaaar x)))
(define cdaadr (lambda (x) (#2%cdaadr x)))
(define cdadar (lambda (x) (#2%cdadar x)))
(define cdaddr (lambda (x) (#2%cdaddr x)))
(define cddaar (lambda (x) (#2%cddaar x)))
(define cddadr (lambda (x) (#2%cddadr x)))
(define cdddar (lambda (x) (#2%cdddar x)))
(define cddddr (lambda (x) (#2%cddddr x)))
(define $list-length)
(define length)
(define list-ref)
(define list-tail)
(define list-head)
(let ()
(define improper-list-error
(lambda (who ls)
($oops who "~s is not a proper list" ls)))
(define circular-list-error
(lambda (who ls)
($oops who "~s is circular" ls)))
(define index-range-error
(lambda (who ls n)
($oops who "index ~s is out of range for list ~s" n ls)))
(define index-type-error
(lambda (who n)
($oops who "index ~s is not an exact nonnegative integer" n)))
(define index-range/improper-list-error
(lambda (who tail ls n)
(if (null? tail)
(index-range-error who ls n)
(improper-list-error who ls))))
(define list-length
(lambda (ls who)
(let loop ([hare ls] [i 0])
(if (pair? hare)
(let ([hare (cdr hare)])
(if (pair? hare)
(if (fx<= i 10000)
(loop (cdr hare) (fx+ i 2))
(let loop ([hare hare] [tortoise hare] [i (fx+ i 1)])
(if (pair? hare)
(let ([hare (cdr hare)])
(if (pair? hare)
(if (eq? hare tortoise)
(circular-list-error who ls)
(loop (cdr hare)
(cdr tortoise)
(fx+ i 2)))
(if (null? hare)
(fx+ i 1)
(improper-list-error who ls))))
(if (null? hare)
i
(improper-list-error who ls)))))
(if (null? hare)
(fx+ i 1)
(improper-list-error who ls))))
(if (null? hare)
i
(improper-list-error who ls))))))
(define list-tail-cycle
(lambda (ls n)
(let loop ((fast (cdr ls)) (i 1))
(if (eq? fast ls)
(let ((i (remainder n i)))
(do ((ls ls (cdr ls)) (i i (fx- i 1)))
((fx= i 0) ls)))
(loop (cdr fast) (fx+ i 1))))))
(define fx-list-tail
(lambda (fast slow i)
(if (fx> i 0)
(if (pair? fast)
(let ((fast (cdr fast)))
(if (fx> i 1)
(if (not (eq? fast slow))
(if (pair? fast)
(fx-list-tail (cdr fast) (cdr slow) (fx- i 2))
(values 'error fast i))
(values 'cycle fast (fx- i 1)))
(values 'okay fast (fx- i 1))))
(values 'error fast i))
(values 'okay fast i))))
(set! $list-length (lambda (ls who) (list-length ls who)))
(set! length
(lambda (ls)
(list-length ls 'length)))
(set! list-ref
(lambda (ls n)
(cond
[(and (fixnum? n) (fx<= 0 n 1000))
(let loop ([l ls] [i n])
(if (pair? l)
(if (fx> i 1)
(let ([l (cdr l)])
(if (pair? l)
(loop (cdr l) (fx- i 2))
(index-range/improper-list-error 'list-ref l ls n)))
(if (fx= i 0)
(car l)
(let ([l (cdr l)])
(if (pair? l)
(car l)
(index-range/improper-list-error 'list-ref l ls n)))))
(index-range/improper-list-error 'list-ref l ls n)))]
[(and (or (fixnum? n) (bignum? n)) (>= n 0))
(let ((m (min n (most-positive-fixnum))))
(call-with-values
(lambda () (fx-list-tail ls ls m))
(lambda (what fast i)
(cond
[(and (eq? what 'okay) (pair? fast))
; can't happen with bignum input
(car fast)]
[(eq? what 'cycle)
(car (list-tail-cycle fast (+ i (- n m))))]
[else (index-range/improper-list-error 'list-ref fast ls n)]))))]
[else (index-type-error 'list-ref n)])))
(set! list-tail
(lambda (ls n)
(cond
[(and (fixnum? n) (fx<= 0 n 1000))
(let loop ([l ls] [i n])
(if (fx> i 1)
(if (pair? l)
(let ([l (cdr l)])
(if (pair? l)
(loop (cdr l) (fx- i 2))
(index-range/improper-list-error 'list-tail l ls n)))
(index-range/improper-list-error 'list-tail l ls n))
(if (fx= i 0)
l
(if (pair? l)
(cdr l)
(index-range/improper-list-error 'list-tail l ls n)))))]
[(and (or (fixnum? n) (bignum? n)) (>= n 0))
(let ((m (min n (most-positive-fixnum))))
(call-with-values
(lambda () (fx-list-tail ls ls m))
(lambda (what fast i)
(cond
[(eq? what 'okay) ; can't happen with bignum input
fast]
[(eq? what 'cycle) (list-tail-cycle fast (+ i (- n m)))]
[else (index-range/improper-list-error 'list-tail fast ls n)]))))]
[else (index-type-error 'list-tail n)])))
(set! list-head
(lambda (orig-ls orig-n)
(unless (and (fixnum? orig-n) (fx>= orig-n 0))
($oops 'list-head "invalid index ~s" orig-n))
(let f ([ls orig-ls] [n orig-n])
(cond
[(fx<= n 1)
(if (fx= n 0)
'()
(if (pair? ls)
(list (car ls))
(index-range/improper-list-error 'list-head ls orig-ls orig-n)))]
[(pair? ls)
(let ([a (car ls)] [ls (cdr ls)])
(if (pair? ls)
(list* a (car ls) (f (cdr ls) (fx- n 2)))
(index-range/improper-list-error 'list-head ls orig-ls orig-n)))]
[else (index-range/improper-list-error 'list-head ls orig-ls orig-n)]))))
(set! last-pair
(lambda (ls)
(unless (pair? ls)
($oops 'last-pair "~s is not a pair" ls))
(let loop ((fast ls) (slow ls))
(let ((fast1 (cdr fast)))
(if (pair? fast1)
(let ((fast2 (cdr fast1)))
(if (pair? fast2)
(if (not (eq? fast1 slow))
(loop fast2 (cdr slow))
(circular-list-error 'last-pair ls))
fast1))
fast))))))
(define make-list
(rec make-list
(case-lambda
[(n) (make-list n (void))]
[(n x)
(unless (and (fixnum? n) (fx>= n 0))
($oops 'make-list "invalid size ~s" n))
(let loop ([n n] [ls '()])
(if (fx= n 0) ls (loop (fx- n 1) (cons x ls))))])))
(define-who list-copy
(lambda (ls)
($list-length ls who)
(let f ([ls ls])
(if (null? ls)
ls
(cons (car ls) (f (cdr ls)))))))
(define-who append
(rec append
(case-lambda
[() '()]
[(x1 x2)
($list-length x1 who)
(let f ([ls x1])
(if (null? ls) x2 (cons (car ls) (f (cdr ls)))))]
[(x1 . xr)
(let f ([x1 x1] [xr xr])
(if (null? xr) x1 (append x1 (f (car xr) (cdr xr)))))])))
(define-who append!
(let ()
(define (do-append! x1 x2)
(if (null? x1)
x2
(let f ([ls x1])
(if (null? (cdr ls))
(begin (set-cdr! ls x2) x1)
(f (cdr ls))))))
(case-lambda
[() '()]
[(x1 x2)
($list-length x1 who)
(do-append! x1 x2)]
[(x1 . xr)
(let f ([x1 x1] [xr xr])
(if (null? xr)
x1
(begin
($list-length x1 who) ; make sure all checks occur before first set-cdr!
(do-append! x1 (f (car xr) (cdr xr))))))])))
(define-who reverse
(lambda (ls)
($list-length ls who)
(do ([ls ls (cdr ls)] [a '() (cons (car ls) a)])
((null? ls) a))))
(define-who reverse!
(lambda (ls)
(#%$list-length ls who)
(let loop ([l ls] [a '()])
(cond
[(pair? l) (let ([x (cdr l)]) (set-cdr! l a) (loop x l))]
[(null? l) a]
[else
(let loop ([l a] [a l])
(let ([x (cdr l)]) (set-cdr! l a) (loop x l)))]))))
(let ()
(define-syntax do-assoc
(syntax-rules ()
((_ x alist who pred?)
(let loop ((fast alist) (slow alist))
(cond
[(pair? fast)
(let ((a (car fast)))
(if (pair? a)
(if (pred? (car a) x)
a
(let ((fast (cdr fast)))
(cond
[(pair? fast)
(let ((a (car fast)))
(if (pair? a)
(if (pred? (car a) x)
a
(if (eq? fast slow)
(cyclic-alist who alist)
(loop (cdr fast) (cdr slow))))
(improper-alist who alist)))]
[(null? fast) #f]
[else (improper-alist who alist)])))
(improper-alist who alist)))]
[(null? fast) #f]
[else (improper-alist who alist)])))))
(define improper-alist
(lambda (who alist)
($oops who "improperly formed alist ~s" alist)))
(define cyclic-alist
(lambda (who alist)
($oops who "cyclic alist ~s" alist)))
(define ass-eq?
(lambda (x alist who)
(do-assoc x alist who eq?)))
(set! assq
(lambda (x alist)
(ass-eq? x alist 'assq)))
(set! assv
(lambda (x alist)
(if (or (symbol? x) (#%$immediate? x))
(ass-eq? x alist 'assv)
(do-assoc x alist 'assv eqv?))))
(set! assoc
(lambda (x alist)
(cond
[(string? x)
(do-assoc x alist 'assoc
(lambda (x y) (and (string? x) (string=? x y))))]
[(or (symbol? x) (#%$immediate? x))
(ass-eq? x alist 'assoc)]
[else
(do-assoc x alist 'assoc equal?)])))
(set! assp
(lambda (pred? alist)
(unless (procedure? pred?)
($oops 'assp "~s is not a procedure" pred?))
(let loop ((fast alist) (slow alist))
(cond
[(pair? fast)
(let ((a (car fast)))
(if (pair? a)
(if (pred? (car a))
a
(let ((fast (cdr fast)))
(cond
[(pair? fast)
(let ((a (car fast)))
(if (pair? a)
(if (pred? (car a))
a
(if (eq? fast slow)
(cyclic-alist 'assp alist)
(loop (cdr fast) (cdr slow))))
(improper-alist 'assp alist)))]
[(null? fast) #f]
[else (improper-alist 'assp alist)])))
(improper-alist 'assp alist)))]
[(null? fast) #f]
[else (improper-alist 'assp alist)]))))
)
(let ()
(define improper-list
(lambda (who ls)
($oops who "improper list ~s" ls)))
(define cyclic-list
(lambda (who ls)
($oops who "cyclic list ~s" ls)))
(define-syntax do-member
(syntax-rules ()
((_ x ls who pred?)
(let loop ((fast ls) (slow ls))
(cond
[(pair? fast)
(if (pred? (car fast) x)
fast
(let ((fast (cdr fast)))
(cond
[(pair? fast)
(if (pred? (car fast) x)
fast
(if (eq? fast slow)
(cyclic-list who ls)
(loop (cdr fast) (cdr slow))))]
[(null? fast) #f]
[else (improper-list who ls)])))]
[(null? fast) #f]
[else (improper-list who ls)])))))
(define mem-eq?
(lambda (x ls who)
(do-member x ls who eq?)))
(set! memq
(lambda (x ls)
(mem-eq? x ls 'memq)))
(set! memv
(lambda (x ls)
(if (or (symbol? x) (fixnum? x) (char? x) (procedure? x))
(mem-eq? x ls 'memv)
(do-member x ls 'memv eqv?))))
(set! member
(lambda (x ls)
(cond
[(string? x)
(do-member x ls 'member
(lambda (x y) (and (string? x) (string=? x y))))]
[(or (symbol? x) (fixnum? x) (char? x) (procedure? x))
(mem-eq? x ls 'member)]
[else
(do-member x ls 'member equal?)])))
(set! memp
(lambda (pred? ls)
(unless (procedure? pred?)
($oops 'memp "~s is not a procedure" pred?))
(let loop ((fast ls) (slow ls))
(cond
[(pair? fast)
(if (pred? (car fast))
fast
(let ((fast (cdr fast)))
(cond
[(pair? fast)
(if (pred? (car fast))
fast
(if (eq? fast slow)
(cyclic-list 'memp ls)
(loop (cdr fast) (cdr slow))))]
[(null? fast) #f]
[else (improper-list 'memp ls)])))]
[(null? fast) #f]
[else (improper-list 'memp ls)]))))
(set! find
(lambda (pred? ls)
(unless (procedure? pred?)
($oops 'find "~s is not a procedure" pred?))
(let loop ((fast ls) (slow ls))
(cond
[(pair? fast)
(if (pred? (car fast))
(car fast)
(let ((fast (cdr fast)))
(cond
[(pair? fast)
(if (pred? (car fast))
(car fast)
(if (eq? fast slow)
(cyclic-list 'find ls)
(loop (cdr fast) (cdr slow))))]
[(null? fast) #f]
[else (improper-list 'find ls)])))]
[(null? fast) #f]
[else (improper-list 'find ls)]))))
)
(let ()
(define improper-list
(lambda (who ls)
($oops who "~s is not a proper list" ls)))
(define-syntax do-remove
(syntax-rules ()
((_ x ls pred?)
(let f ((x x) (fast ls) (slow ls))
(if (pair? fast)
(let ((fast1 (cdr fast)))
(if (pair? fast1)
(and (not (eq? fast1 slow))
(let ((fast2 (cdr fast1)))
(let ((rest (f x fast2 (cdr slow))))
(and rest
(if (not (pred? (car fast) x))
(if (not (pred? (car fast1) x))
(if (eq? rest fast2)
fast
(list* (car fast) (car fast1) rest))
(cons (car fast) rest))
(if (not (pred? (car fast1) x))
(if (eq? rest fast2)
fast1
(cons (car fast1) rest))
rest))))))
(and (null? fast1)
(if (not (pred? (car fast) x))
fast
'()))))
(and (null? fast) '()))))))
(define rem-eq?
(lambda (x l)
(do-remove x l eq?)))
(set! remq
(lambda (x ls)
(or (rem-eq? x ls)
(improper-list 'remq ls))))
(set! remv
(lambda (x ls)
(or (if (or (symbol? x) (fixnum? x) (char? x) (procedure? x))
(rem-eq? x ls)
(do-remove x ls eqv?))
(improper-list 'remv ls))))
(set! remove
(lambda (x ls)
(or (cond
[(string? x)
(do-remove x ls
(lambda (x y) (and (string? x) (string=? x y))))]
[(or (symbol? x) (fixnum? x) (char? x) (procedure? x))
(rem-eq? x ls)]
[else
(do-remove x ls equal?)])
(improper-list 'remove ls))))
(set! remp
(lambda (pred? ls)
(unless (procedure? pred?)
($oops 'remp "~s is not a procedure" pred?))
(or (let f ((pred? pred?) (fast ls) (slow ls))
(if (pair? fast)
(let ((fast1 (cdr fast)))
(if (pair? fast1)
(and (not (eq? fast1 slow))
(let ((fast2 (cdr fast1)))
(let ((rest (f pred? fast2 (cdr slow))))
(and rest
(if (not (pred? (car fast)))
(if (not (pred? (car fast1)))
(if (eq? rest fast2)
fast
(list* (car fast) (car fast1) rest))
(cons (car fast) rest))
(if (not (pred? (car fast1)))
(if (eq? rest fast2)
fast1
(cons (car fast1) rest))
rest))))))
(and (null? fast1)
(if (not (pred? (car fast)))
fast
'()))))
(and (null? fast) '())))
(improper-list 'remp ls))))
(set! filter
(lambda (pred? ls)
(unless (procedure? pred?)
($oops 'filter "~s is not a procedure" pred?))
(or (let f ((pred? pred?) (fast ls) (slow ls))
(if (pair? fast)
(let ((fast1 (cdr fast)))
(if (pair? fast1)
(and (not (eq? fast1 slow))
(let ((fast2 (cdr fast1)))
(let ((rest (f pred? fast2 (cdr slow))))
(and rest
(if (pred? (car fast))
(if (pred? (car fast1))
(if (eq? rest fast2)
fast
(list* (car fast) (car fast1) rest))
(cons (car fast) rest))
(if (pred? (car fast1))
(if (eq? rest fast2)
fast1
(cons (car fast1) rest))
rest))))))
(and (null? fast1)
(if (pred? (car fast))
fast
'()))))
(and (null? fast) '())))
(improper-list 'filter ls))))
(set! partition
(lambda (pred? ls)
(unless (procedure? pred?)
($oops 'partition "~s is not a procedure" pred?))
(let f ([pred? pred?] [fast ls] [slow ls] [ls ls])
(if (pair? fast)
(let ([fast1 (cdr fast)])
(if (pair? fast1)
(if (eq? fast1 slow)
(improper-list 'partition ls)
(let ([fast2 (cdr fast1)])
(let-values ([(ins outs) (f pred? fast2 (cdr slow) ls)])
(if (pred? (car fast))
(if (pred? (car fast1))
(values
(if (eq? ins fast2)
fast
(list* (car fast) (car fast1) ins))
outs)
(values
(cons (car fast) ins)
(if (eq? outs fast2)
fast1
(cons (car fast1) outs))))
(if (pred? (car fast1))
(values
(if (eq? ins fast2)
fast1
(cons (car fast1) ins))
(cons (car fast) outs))
(values
ins
(if (eq? outs fast2)
fast
(list* (car fast) (car fast1) outs))))))))
(if (null? fast1)
(if (pred? (car fast))
(values fast '())
(values '() fast))
(improper-list 'partition ls))))
(if (null? fast)
(values '() '())
(improper-list 'partition ls))))))
)
(let ()
(define-syntax do-rem!
(syntax-rules ()
((_ pred?)
(rec rem!
(lambda (x ls)
(if (not (null? ls))
(if (not (pred? (car ls) x))
(begin
(let loop ((ls (cdr ls)) (prev ls))
(unless (null? ls)
(if (not (pred? (car ls) x))
(loop (cdr ls) ls)
(set-cdr! prev (rem! x (cdr ls))))))
ls)
(rem! x (cdr ls)))
'()))))))
(define rem-eq?! (do-rem! eq?))
(set! remq!
(lambda (x ls)
($list-length ls 'remq!)
(rem-eq?! x ls)))
(set! remv!
(lambda (x ls)
($list-length ls 'remv!)
(if (or (symbol? x) (fixnum? x) (char? x) (procedure? x))
(rem-eq?! x ls)
((do-rem! eqv?) x ls))))
(set! remove!
(lambda (x ls)
($list-length ls 'remove!)
(if (or (symbol? x) (fixnum? x) (char? x) (procedure? x))
(rem-eq?! x ls)
((do-rem! equal?) x ls))))
)
(define substq
(lambda (new old tree)
(let f ([tree tree])
(if (eq? old tree)
new
(if (pair? tree)
(let ([a (f (car tree))] [d (f (cdr tree))])
(if (and (eq? a (car tree)) (eq? d (cdr tree)))
tree
(cons a d)))
tree)))))
(define substq!
(lambda (new old tree)
(let f ([tree tree])
(if (eq? old tree)
new
(if (pair? tree)
(begin
(set-car! tree (f (car tree)))
(set-cdr! tree (f (cdr tree)))
tree)
tree)))))
(define substv
(lambda (new old tree)
(let f ([tree tree])
(if (eqv? old tree)
new
(if (pair? tree)
(let ([a (f (car tree))] [d (f (cdr tree))])
(if (and (eq? a (car tree)) (eq? d (cdr tree)))
tree
(cons a d)))
tree)))))
(define substv!
(lambda (new old tree)
(let f ([tree tree])
(if (eqv? old tree)
new
(if (pair? tree)
(begin
(set-car! tree (f (car tree)))
(set-cdr! tree (f (cdr tree)))
tree)
tree)))))
(define subst
(lambda (new old tree)
(let f ([tree tree])
(if (equal? old tree)
new
(if (pair? tree)
(let ([a (f (car tree))] [d (f (cdr tree))])
(if (and (eq? a (car tree)) (eq? d (cdr tree)))
tree
(cons a d)))
tree)))))
(define subst!
(lambda (new old tree)
(let f ([tree tree])
(if (equal? old tree)
new
(if (pair? tree)
(begin
(set-car! tree (f (car tree)))
(set-cdr! tree (f (cdr tree)))
tree)
tree)))))
(let ()
(define ($iota n ls)
(if (fx> n 0)
($iota (fx- n 2) (list* (fx- n 1) n ls))
(if (fx= n 0)
(cons 0 ls)
ls)))
; (iota n) => (0 1 ... n-1)
(set! iota
(lambda (n)
(unless (and (fixnum? n) (fx>= n 0))
($oops 'iota "~s is not a nonnegative fixnum" n))
($iota (fx- n 1) '())))
; (enumerate '(a1 a2 ... aN)) => (0 1 ... n-1)
(set! enumerate
(lambda (ls)
($iota (fx- ($list-length ls 'enumerate) 1) '()))))
)