lists.scm 3.2 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145
  1. ;;; Lists
  2. ;;; Copyright (C) 2024 Igalia, S.L.
  3. ;;;
  4. ;;; Licensed under the Apache License, Version 2.0 (the "License");
  5. ;;; you may not use this file except in compliance with the License.
  6. ;;; You may obtain a copy of the License at
  7. ;;;
  8. ;;; http://www.apache.org/licenses/LICENSE-2.0
  9. ;;;
  10. ;;; Unless required by applicable law or agreed to in writing, software
  11. ;;; distributed under the License is distributed on an "AS IS" BASIS,
  12. ;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
  13. ;;; See the License for the specific language governing permissions and
  14. ;;; limitations under the License.
  15. ;;; Commentary:
  16. ;;;
  17. ;;; Lists.
  18. ;;;
  19. ;;; Code:
  20. (library (hoot lists)
  21. (export length
  22. list-ref list-set! list-tail
  23. list?
  24. make-list
  25. reverse append list-copy
  26. map for-each fold
  27. acons)
  28. (import (hoot primitives)
  29. (hoot cond-expand)
  30. (hoot match)
  31. (hoot pairs)
  32. (hoot numbers)
  33. (hoot values))
  34. (define (not x) (if x #f #t))
  35. (define (length l)
  36. (let lp ((len 0) (l l))
  37. (if (null? l) len (lp (1+ len) (cdr l)))))
  38. (define (list-ref l n)
  39. (let lp ((l l) (n n))
  40. (if (zero? n)
  41. (car l)
  42. (lp (cdr l) (1- n)))))
  43. (define (list-set! l n x)
  44. (let lp ((l l) (n n))
  45. (if (zero? n)
  46. (set-car! l x)
  47. (lp (cdr l) (1- n)))))
  48. (define (list-tail l n)
  49. (let lp ((l l) (n n))
  50. (if (zero? n)
  51. l
  52. (lp (cdr l) (1- n)))))
  53. (define (list? l)
  54. (let lp ((l l))
  55. (match l
  56. (() #t)
  57. ((_ . l) (lp l))
  58. (_ #f))))
  59. (define (make-list n init)
  60. (let lp ((n n) (out '()))
  61. (if (zero? n)
  62. out
  63. (lp (1- n) (cons init out)))))
  64. (define (reverse l)
  65. (let lp ((out '()) (l l))
  66. (match l
  67. (() out)
  68. ((head . tail) (lp (cons head out) tail)))))
  69. (define append
  70. (case-lambda
  71. (() '())
  72. ((x) x)
  73. ((x y) (%append x y))
  74. ((x y . z) (%append x (apply append y z)))))
  75. (define (list-copy l)
  76. (append l '()))
  77. (define (fold f seed l)
  78. (let lp ((seed seed) (l l))
  79. (match l
  80. (() seed)
  81. ((x . l) (lp (f x seed) l)))))
  82. ;; Temp definitions!
  83. (define map
  84. (case-lambda
  85. ((f l)
  86. (let lp ((l l))
  87. (match l
  88. (() '())
  89. ((x . l) (cons (f x) (lp l))))))
  90. ((f l1 l2)
  91. (let lp ((l1 l1) (l2 l2))
  92. (match l1
  93. (() '())
  94. ((x . l1)
  95. (match l2
  96. (() '())
  97. ((y . l2)
  98. (cons (f x y) (lp l1 l2))))))))))
  99. (define for-each
  100. (case-lambda
  101. ((f l)
  102. (let lp ((l l))
  103. (unless (null? l)
  104. (f (car l))
  105. (lp (cdr l)))))
  106. ((f l1 l2)
  107. (let lp ((l1 l1) (l2 l2))
  108. (match l1
  109. (() (values))
  110. ((x . l1)
  111. (match l2
  112. (() (values))
  113. ((y . l2)
  114. (f x y)
  115. (lp l1 l2)))))))))
  116. (define (acons x y z) (cons (cons x y) z))
  117. (cond-expand
  118. (guile-vm)
  119. (hoot
  120. (%inline-wasm
  121. '(func (param $append (ref $proc))
  122. (global.set $append-primitive (local.get $append)))
  123. (lambda (x z)
  124. (let lp ((x x))
  125. (if (null? x)
  126. z
  127. (cons (car x) (lp (cdr x))))))))))