Merge pull request #114 from jitwit/rnrs-list

add list functions to rnrs.ss

README.md

@@ -26,12 +26,12 @@ from GNU Guile.
 As mentioned, the goal has been to prioritize features needed for self
 hosting. Here are some of the current restrictions:
 
-* Functions may only be created with `define`, and particularly only the
-  `(define (foo args ...) body)` form.
 * No use of `syntax-case`, `syntax-rules`, or `define-syntax`.
 * Only one file to start with, so we don't have to figure out how to link
   multiple libraries.
-* Only use `define` to create functions, not global variables or objects.
+* Only use `define` to create top level functions and variables.
+* Only fixed arity functions can be defined, forms such as `(define (f
+  x . args ...)` are not supported.
 * Use a small amount of syntax, because we won't have a proper macro expander at
   first. There is a pass to expand some of the simpler and more useful macros.
 * Restrict data types and operations on those. For now, we can use:

scheme-lib/rnrs.ss

@@ -13,13 +13,14 @@
 ;; limitations under the License.
 
 (library (rnrs)
-  (export > append assp assq boolean? caaar caadar caaddr caadr caar cadadr
-          cadar caddar cadddr caddr cadr car cdaddr cdadr cdar cddar cdddr cddr
-          cdr char->integer char-ci<? char-numeric? char-whitespace? display
-          equal? fold-left fold-right integer->char length list->string list-ref
-          list-tail list? map max memp memq newline null? peek-char read read-char
-          string->list string->symbol string=? symbol->string string-append
-          symbol? write write-char zero?)
+  (export > append assoc assp assq boolean? caaar caadar caaddr caadr caar
+          cadadr cadar caddar cadddr caddr cadr car cdaddr cdadr cdar cddar
+          cdddr cddr cdr char->integer char-ci<? char-numeric? char-whitespace?
+          display even? equal? filter find fold-left fold-right integer->char
+          iota length list->string list-ref list-tail list? map max member memp
+          memq newline null? odd? peek-char read read-char remove remp remq
+          reverse string->list string->symbol string=? symbol->string
+          string-append symbol? write write-char zero?)
   (import (schism))
 
   (define (display x)
@@ -115,6 +116,11 @@
   (define (cadadr p) (car (cdadr p)))
   (define (cadddr p) (car (cdddr p)))
   (define (cdaddr p) (cdr (caddr p)))
+  (define (member x ls)
+    (cond
+     ((null? ls) #f)
+     ((equal? x (car ls)) ls)
+     (else (member x (cdr ls)))))
   (define (memp p ls)
     (cond
      ((null? ls) #f)
@@ -125,6 +131,14 @@
      ((null? ls) #f)
      ((eq? (car ls) x) ls)
      (else (memq x (cdr ls)))))
+  (define (assoc x ls)
+    (if (pair? ls)
+        (if (equal? x (caar ls))
+            (car ls)
+            (assoc x (cdr ls)))
+        (if (null? ls)
+            #f
+            (begin (display x) (newline) (error 'assoc "not a list")))))
   (define (assp p ls)
     (if (pair? ls)
         (if (p (caar ls))
@@ -141,6 +155,26 @@
         (if (null? ls)
             #f
             (begin (display x) (newline) (error 'assq "not a list")))))
+  (define (find pred ls)
+    (and (pair? ls)
+         (if (pred (car ls))
+             (car ls)
+             (find pred (cdr ls)))))
+  (define (remove x ls)
+    (filter (lambda (y) (not (equal? x y))) ls))
+  (define (remp pred ls)
+    (filter (lambda (y) (not (pred y))) ls))
+  (define (remq x ls)
+    (filter (lambda (y) (not (eq? x y))) ls))
+  (define ($iota i n)
+    (if (eq? i n)
+        '()
+        (cons i ($iota (+ i 1) n))))
+  (define (iota n)
+    (unless (and (number? n) (< -1 n))
+      ;; number? is currently valid because all numbers are i32
+      (error 'iota "not a nonnegative fixnum"))
+    ($iota 0 n))
   (define (length ls)
     (cond
      ((null? ls) 0)
@@ -154,6 +188,10 @@
     (car (list-tail list n)))
   (define (append a b)
     (fold-right cons b a))
+  (define (filter pred ls)
+    (fold-right (lambda (x ls) (if (pred x) (cons x ls) ls)) '() ls))
+  (define (reverse ls)
+    (fold-left (lambda (x y) (cons y x)) '() ls))
   (define (char->integer c)
     (if (char? c)
         (%char-value c)
@@ -219,6 +257,10 @@
     (< b a))
   (define (max a b)
     (if (< a b) b a))
+  (define (even? x)
+    (eq? 0 (mod0 x 2)))
+  (define (odd? x)
+    (not (eq? 0 (mod0 x 2))))
   (define (peek-char)
     (let ((i (%peek-char)))
       (if (< i 0)

schism/compiler.ss

@@ -42,10 +42,6 @@
         (cons x set)))
   (define (remove-duplicates ls same?)
     (fold-right (lambda (x ls) (adjoin x ls same?)) '() ls))
-  (define (filter pred ls)
-    (fold-right (lambda (x ls) (if (pred x) (cons x ls) ls)) '() ls))
-  (define (filter-out pred ls)
-    (filter (lambda (x) (not (pred x))) ls))
   (define (and-map f ls)
     (or (null? ls) (and (f (car ls)) (and-map f (cdr ls)))))
   (define (or-map f ls)
@@ -499,6 +495,9 @@
       `(,(cons name args*) ,body)))
   (define (define-value def env)
     (let* ((name (definition-name def))
+           ;; this uses the property that the most recent definitions
+           ;; appear at beginning of environment alist to detect
+           ;; unbound references in the definition body.
            (env (memp (lambda (n.d) (eq? name (car n.d))) env))
            (body (if (null? (cddr def))
                      `(const ,(void))
@@ -529,11 +528,11 @@
   (define (parse-libraries libs)
     (let ((imported-envs (map make-export-environment libs)))
       (let ((first (parse-library (car libs) imported-envs))
-            (imported-functions (fold-left (lambda (functions lib)
-                                             (append functions
-                                                     (cdr (parse-library lib imported-envs))))
-                                           '()
-                                           (cdr libs))))
+            (imported-functions (fold-right (lambda (lib functions)
+                                              (append (cdr (parse-library lib imported-envs))
+                                                      functions))
+                                            '()
+                                            (cdr libs))))
         (append first imported-functions))))
 
   (define (add-imported imports import-envs env)
@@ -1116,7 +1115,7 @@
            (cache (car env))
            (nglobals (cadr env))
            (fun? (lambda (x) (pair? (car x))))
-           (defs (filter-out fun? fns))
+           (defs (remp fun? fns))
            (fns (filter fun? fns))
            (start (fold-left (lambda (start def)
                                `(seq ,start
@@ -1628,7 +1627,7 @@
            (exports (car exports+fns))
            (fns (cdr exports+fns))
            (imports (filter wasm-import? fns))
-           (fns (filter-out wasm-import? fns))
+           (fns (remp wasm-import? fns))
            (fns (simplify-definitions fns))
            (fns (convert-closures fns))
            (fns+vars+globals+start (lower-literals-in-definitions fns))

test/assoc.ss

@@ -0,0 +1,29 @@
+;; Copyright 2020 Google LLC
+;;
+;; 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.
+
+(library (test assoc)
+  (export do-test)
+  (import (rnrs)
+          (rnrs mutable-pairs))
+
+  (define alist
+    `((2 . a) (3 . b)))
+
+  (define (do-test)
+    (set-cdr! (assoc 3 alist) 'c)
+    (and (equal? (assoc '(a) '(((a) . a) (-1 . b)))
+                 '((a) . a))
+         (not (assoc '(a) '(((b) . b) (a . c))))
+         (equal? alist
+                 `((2 . a) (3 . c))))))

test/assq.ss

@@ -0,0 +1,23 @@
+;; Copyright 2020 Google LLC
+;;
+;; 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.
+
+(library (test assq)
+  (export do-test)
+  (import (rnrs))
+
+  (define (do-test)
+    (and (equal? '(b . 2)
+                 (assq 'b '((a . 1) (b . 2))))
+         (eq? 2 (cdr (assq 'b '((a . 1) (b . 2)))))
+         (not (assq 'c '((a . 1) (b . 2)))))))

test/even.ss

@@ -0,0 +1,24 @@
+;; Copyright 2020 Google LLC
+;;
+;; 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.
+
+(library (test even)
+  (export do-test)
+  (import (rnrs))
+
+  (define (do-test)
+    (and (even? 0)
+         (even? 2)
+         (even? -2)
+         (not (even? -1))
+         (not (even? 3)))))

test/filter.ss

@@ -0,0 +1,24 @@
+;; Copyright 2020 Google LLC
+;;
+;; 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.
+
+(library (test filter)
+  (export do-test)
+  (import (rnrs))
+
+  (define (do-test)
+    (and (equal? (filter (lambda (x) (and (> x 0) (< x 10)))
+                         '(-5 15 3 14 -20 6 0 -9))
+                 '(3 6))
+         (equal? (filter odd? (iota 5))
+                 '(1 3)))))

test/find.ss

@@ -0,0 +1,23 @@
+;; Copyright 2020 Google LLC
+;;
+;; 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.
+
+(library (test find)
+  (export do-test)
+  (import (rnrs))
+
+  (define (do-test)
+    (and (eq? 3 (find odd? '(2 3 5 7 11)))
+         (eq? 2 (find even? '(2 3 5 7 11)))
+         (not (find even? '(3 5 7 11)))
+         (not (find (lambda (x) (not x)) '(2 3 #f 7 11))))))

test/iota.ss

@@ -0,0 +1,21 @@
+;; Copyright 2020 Google LLC
+;;
+;; 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.
+
+(library (test iota)
+  (export do-test)
+  (import (rnrs))
+
+  (define (do-test)
+    (and (equal? '(0 1 2) (iota 3))
+         (null? (iota 0)))))

test/odd.ss

@@ -0,0 +1,24 @@
+;; Copyright 2020 Google LLC
+;;
+;; 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.
+
+(library (test odd)
+  (export do-test)
+  (import (rnrs))
+
+  (define (do-test)
+    (and (not (odd? 0))
+         (not (odd? 2))
+         (not (odd? -2))
+         (odd? -1)
+         (odd? 3))))

test/remove.ss

@@ -0,0 +1,21 @@
+;; Copyright 2020 Google LLC
+;;
+;; 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.
+
+(library (test remove)
+  (export do-test)
+  (import (rnrs))
+
+  (define (do-test)
+    (equal? (remove '(b) '((a) (b) (c)))
+            '((a) (c)))))

test/remp.ss

@@ -0,0 +1,24 @@
+;; Copyright 2020 Google LLC
+;;
+;; 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.
+
+(library (test remp)
+  (export do-test)
+  (import (rnrs))
+
+  (define (do-test)
+    (and (equal? (remp odd? '(1 2 3 4))
+                 '(2 4))
+         (equal? (remp (lambda (x) (and (> x 0) (< x 10)))
+                       '(-5 15 3 14 -20 6 0 -9))
+                 '(-5 15 14 -20 0 -9)))))