123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145 |
- ;;; Lists
- ;;; Copyright (C) 2024 Igalia, S.L.
- ;;;
- ;;; 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.
- ;;; Commentary:
- ;;;
- ;;; Lists.
- ;;;
- ;;; Code:
- (library (hoot lists)
- (export length
- list-ref list-set! list-tail
- list?
- make-list
- reverse append list-copy
- map for-each fold
- acons)
- (import (hoot primitives)
- (hoot cond-expand)
- (hoot match)
- (hoot pairs)
- (hoot numbers)
- (hoot values))
- (define (not x) (if x #f #t))
- (define (length l)
- (let lp ((len 0) (l l))
- (if (null? l) len (lp (1+ len) (cdr l)))))
- (define (list-ref l n)
- (let lp ((l l) (n n))
- (if (zero? n)
- (car l)
- (lp (cdr l) (1- n)))))
- (define (list-set! l n x)
- (let lp ((l l) (n n))
- (if (zero? n)
- (set-car! l x)
- (lp (cdr l) (1- n)))))
- (define (list-tail l n)
- (let lp ((l l) (n n))
- (if (zero? n)
- l
- (lp (cdr l) (1- n)))))
- (define (list? l)
- (let lp ((l l))
- (match l
- (() #t)
- ((_ . l) (lp l))
- (_ #f))))
- (define (make-list n init)
- (let lp ((n n) (out '()))
- (if (zero? n)
- out
- (lp (1- n) (cons init out)))))
- (define (reverse l)
- (let lp ((out '()) (l l))
- (match l
- (() out)
- ((head . tail) (lp (cons head out) tail)))))
- (define append
- (case-lambda
- (() '())
- ((x) x)
- ((x y) (%append x y))
- ((x y . z) (%append x (apply append y z)))))
- (define (list-copy l)
- (append l '()))
- (define (fold f seed l)
- (let lp ((seed seed) (l l))
- (match l
- (() seed)
- ((x . l) (lp (f x seed) l)))))
- ;; Temp definitions!
- (define map
- (case-lambda
- ((f l)
- (let lp ((l l))
- (match l
- (() '())
- ((x . l) (cons (f x) (lp l))))))
- ((f l1 l2)
- (let lp ((l1 l1) (l2 l2))
- (match l1
- (() '())
- ((x . l1)
- (match l2
- (() '())
- ((y . l2)
- (cons (f x y) (lp l1 l2))))))))))
- (define for-each
- (case-lambda
- ((f l)
- (let lp ((l l))
- (unless (null? l)
- (f (car l))
- (lp (cdr l)))))
- ((f l1 l2)
- (let lp ((l1 l1) (l2 l2))
- (match l1
- (() (values))
- ((x . l1)
- (match l2
- (() (values))
- ((y . l2)
- (f x y)
- (lp l1 l2)))))))))
- (define (acons x y z) (cons (cons x y) z))
- (cond-expand
- (guile-vm)
- (hoot
- (%inline-wasm
- '(func (param $append (ref $proc))
- (global.set $append-primitive (local.get $append)))
- (lambda (x z)
- (let lp ((x x))
- (if (null? x)
- z
- (cons (car x) (lp (cdr x))))))))))
|