Init

cs420-acc/l3-warmup/library/README.org

@@ -0,0 +1,55 @@
+#+OPTIONS: toc:nil author:nil
+#+TITLE: The L₃ library
+
+* Introduction
+
+This directory contains a basic library for L₃. It defines two kinds of modules:
+
+  1. Modules providing functions on values of the built-in types (unit, booleans, characters and integers).
+
+  2. Modules providing new types and functions to operate on these types. All these types are represented as tagged blocks.
+
+* Modules
+
+The table below lists the modules belonging to the standard library, their prefix and the block tag(s) they use, if any. Both the prefix and the tag(s) must be globally unique.
+
+Modules for predefined, tagged types:
+
+|--------------+-----------+--------------------------------------------|
+| Module       | Prefix    | Note                                       |
+|--------------+-----------+--------------------------------------------|
+| =booleans=   | =boolean= |                                            |
+| =characters= | =char=    |                                            |
+| =integers=   | =int=     | Operators (+, <, ...) don't use the prefix |
+| =unit=       | =unit=    |                                            |
+|--------------+-----------+--------------------------------------------|
+
+Modules for additional types, predefined or not but represented as tagged blocks with the given tag(s):
+
+|-----------------+------------+--------|
+| Module          | Prefix     | Tag(s) |
+|-----------------+------------+--------|
+| =pairs=         | =pair=     |      0 |
+| =vectors=       | =vector=   |      1 |
+| =lists=         | =list=     |    2,3 |
+| =disjoint-sets= | =diset=    |      4 |
+| =random=        | =rng=      |     50 |
+| =strings=       | =string=   |    200 |
+| =functions=     | =function= |    202 |
+|-----------------+------------+--------|
+
+A meta-module called =lib= requires all the above modules.
+
+* Naming conventions
+
+With a few exceptions, all entities defined by the various modules obey the following naming conventions:
+
+  - Entities defined in a module have a name starting with the (globally unique) prefix assigned to that module, given in the tables above.
+
+  - Private entities that are not meant to be used outside of the module they are defined in have a name starting with a "%", followed by the module prefix.
+
+  - Functions with side-effect have a name ending with a "!".
+
+  - Predicates (functions returning a boolean) have a name ending with a "?". Type-testing predicates are simply named by concatenating the prefix of that type with a "?".
+
+  - Conversion functions from a type t1 to a type t2 have a name formed by concatenating the prefix of t1, the string "->" and the prefix of t2.

cs420-acc/l3-warmup/library/booleans.l3

@@ -0,0 +1,5 @@
+;; In Emacs, open this file in -*- Scheme -*- mode.
+
+;; Booleans
+
+(def boolean? (fun (o) (@bool? o)))

cs420-acc/l3-warmup/library/booleans.l3m

@@ -0,0 +1 @@
+booleans.l3

cs420-acc/l3-warmup/library/characters.l3

@@ -0,0 +1,89 @@
+;; In Emacs, open this file in -*- Scheme -*- mode
+
+;; Characters
+
+(def newline (@int->char 10))
+
+(def char? (fun (o) (@char? o)))
+
+(def char->int (fun (c)
+                    (@char->int c)))
+
+(def int->char (fun (c)
+                    (@int->char c)))
+
+(def char-read
+     (let ((read-cont-byte (fun () (@and (@byte-read) #b00111111)))
+           (<< (fun (x y) (@shift-left x y)))
+           (b-and (fun (x y) (@and x y)))
+           (b-or@2 (fun (x y) (@or x y)))
+           (b-or@3 (fun (x y z) (@or (@or x y) z)))
+           (b-or@4 (fun (x y z t) (@or (@or x y) (@or z t))))
+           (= (fun (x y) (@= x y))))
+       (fun ()
+            (let ((b0 (@byte-read)))
+              (cond
+               ((= -1 b0)                            ;EOF
+                #f)
+               ((= 0 (b-and #b10000000 b0))          ;1 byte
+                (int->char b0))
+               ((= #b11000000 (b-and #b11100000 b0)) ;2 bytes
+                (let ((b1 (read-cont-byte)))
+                  (int->char (b-or (<< (b-and #b11111 b0) 6)
+                                   b1))))
+               ((= #b11100000 (b-and #b11110000 b0)) ;3 bytes
+                (let ((b1 (read-cont-byte))
+                      (b2 (read-cont-byte)))
+                  (int->char (b-or (<< (b-and #b1111 b0) 12)
+                                   (<< b1 6)
+                                   b2))))
+               (#t                                   ;4 bytes
+                (let ((b1 (read-cont-byte))
+                      (b2 (read-cont-byte))
+                      (b3 (read-cont-byte)))
+                  (int->char (b-or (<< (b-and #b111 b0) 18)
+                                   (<< b1 12)
+                                   (<< b2 6)
+                                   b3)))))))))
+
+(def char-print
+     (let ((<= (fun (x y) (@<= x y)))
+           (>> (fun (x y) (@shift-right x y)))
+           (b-and (fun (x y) (@and x y)))
+           (b-or (fun (x y) (@or x y))))
+       (fun (c)
+            (let ((p (char->int c)))
+              (cond
+               ((<= p #x00007F)                      ;1 byte
+                (@byte-write p))
+               ((<= p #x0007FF)                      ;2 bytes
+                (@byte-write (b-or #b11000000 (>> p 6)))
+                (@byte-write (b-or #b10000000 (b-and p #b111111))))
+               ((<= p #x00FFFF)                      ;3 bytes
+                (@byte-write (b-or #b11100000 (>> p 12)))
+                (@byte-write (b-or #b10000000 (b-and (>> p 6) #b111111)))
+                (@byte-write (b-or #b10000000 (b-and p #b111111))))
+               (#t                                   ;4 bytes
+                (@byte-write (b-or #b11110000 (>> p 18)))
+                (@byte-write (b-or #b10000000 (b-and (>> p 12) #b111111)))
+                (@byte-write (b-or #b10000000 (b-and (>> p 6) #b111111)))
+                (@byte-write (b-or #b10000000 (b-and p #b111111)))))))))
+
+(def newline-print (fun () (char-print newline)))
+
+(def char-digit?
+     (let ((int-0 (@char->int '0'))
+           (int-9 (@char->int '9')))
+       (fun (c)
+            (let ((int-c (@char->int c)))
+              (and (@<= int-0 int-c) (@<= int-c int-9))))))
+
+(def char-digit->int
+     (let ((int-0 (@char->int '0')))
+       (fun (c)
+            (@- (@char->int c) int-0))))
+
+(def int->char-digit
+     (let ((int-0 (@char->int '0')))
+       (fun (i)
+            (@int->char (@+ i int-0)))))

cs420-acc/l3-warmup/library/characters.l3m

@@ -0,0 +1 @@
+characters.l3

cs420-acc/l3-warmup/library/disjoint-sets.l3

@@ -0,0 +1,60 @@
+;; In Emacs, open this file in -*- Scheme -*- mode.
+
+;; Mutable disjoint sets / equivalence classes (a.k.a. "union-find").
+;; See https://en.wikipedia.org/wiki/Disjoint-set_data_structure
+
+(def diset-make
+     (fun ()
+          (let ((e (@block-alloc-4 2)))
+            (@block-set! e 0 #f)       ;parent (#f for representative)
+            (@block-set! e 1 1)        ;rank
+            e)))
+
+(def %diset-parent
+     (fun (e)
+          (@block-get e 0)))
+
+(def %diset-set-parent!
+     (fun (e p)
+          (@block-set! e 0 p)
+          #u))
+
+(def %diset-rank
+     (fun (e)
+          (@block-get e 1)))
+
+(def %diset-set-rank!
+     (fun (e r)
+          (@block-set! e 1 r)
+          #u))
+
+(defrec %diset-repr
+  (fun (e)
+       (let ((maybe-parent (%diset-parent e)))
+         (if maybe-parent
+             (let ((repr (%diset-repr maybe-parent)))
+               (%diset-set-parent! e repr) ;path compression
+               repr)
+             e))))
+
+(def diset?
+     (fun (o)
+          (and (@block? o) (= 4 (@block-tag o)))))
+
+(def diset-merge!
+     (fun (e1 e2)
+          (let ((repr1 (%diset-repr e1))
+                (repr2 (%diset-repr e2)))
+            (if (!= repr1 repr2)
+                (let ((rank1 (%diset-rank repr1)) (rank2 (%diset-rank repr2)))
+                  (cond ((< rank1 rank2)
+                         (%diset-set-parent! repr1 repr2))
+                        ((< rank2 rank1)
+                         (%diset-set-parent! repr2 repr1))
+                        (#t             ;(= rank1 rank2)
+                         (%diset-set-parent! repr1 repr2)
+                         (%diset-set-rank! repr2 (+ 1 rank2)))))))))
+
+(def diset-same?
+     (fun (e1 e2)
+          (= (%diset-repr e1) (%diset-repr e2))))

cs420-acc/l3-warmup/library/disjoint-sets.l3m

@@ -0,0 +1,2 @@
+integers.l3
+disjoint-sets.l3

cs420-acc/l3-warmup/library/functions.l3

@@ -0,0 +1,11 @@
+;; In Emacs, open this file in -*- Scheme -*- mode.
+
+;; Functions
+
+(def function?
+     (fun (o)
+          (and (@block? o) (@= 202 (@block-tag o)))))
+
+(def function-compose
+     (fun (f g)
+          (fun (x) (f (g x)))))

cs420-acc/l3-warmup/library/functions.l3m

@@ -0,0 +1 @@
+functions.l3

cs420-acc/l3-warmup/library/integers.l3

@@ -0,0 +1,158 @@
+;; In Emacs, open this file in -*- Scheme -*- mode.
+
+;; Integers
+
+(def int? (fun (o) (@int? o)))
+
+;; Basic arithmetic
+(def +@2 (fun (x y) (@+ x y)))
+(def +@3 (fun (x y z) (@+ x (@+ y z))))
+(def +@4 (fun (x y z t) (@+ (@+ x y) (@+ z t))))
+(def + +@2)
+
+(def -@1 (fun (x) (@- 0 x)))
+(def -@2 (fun (x y) (@- x y)))
+(def - -@2)
+
+(def *@2 (fun (x y) (@* x y)))
+(def *@3 (fun (x y z) (@* x (@* y z))))
+(def *@4 (fun (x y z t) (@* (@* x y) (@* z t))))
+(def * *@2)
+
+;; Truncated division
+(def /t (fun (x y) (@/ x y)))
+(def %t (fun (x y) (@% x y)))
+
+;; Comparisons
+(def <@2 (fun (x y) (@< x y)))
+(def <@3 (fun (x y z) (and (@< x y) (@< y z))))
+(def < <@2)
+
+(def <=@2 (fun (x y) (@<= x y)))
+(def <=@3 (fun (x y z) (and (@<= x y) (@<= y z))))
+(def <= <=@2)
+
+(def >@2 (fun (x y) (@< y x)))
+(def >@3 (fun (x y z) (and (> x y) (> y z))))
+(def > >@2)
+
+(def >=@2 (fun (x y) (@<= y x)))
+(def >=@3 (fun (x y z) (and (>= x y) (>= y z))))
+(def >= >=@2)
+
+(def = (fun (x y) (@= x y)))
+(def != (fun (x y) (not (@= x y))))
+
+(def int-min (fun (x y) (if (<= x y) x y)))
+(def int-max (fun (x y) (if (>= x y) x y)))
+
+;; Bitwise operations
+(def int-shift-left (fun (x y) (if (>= y 31) 0 (@shift-left x y))))
+
+(def int-shift-right (fun (x y) (if (>= y 31) 0 (@shift-right x y))))
+
+(def int-bitwise-and (fun (x y) (@and x y)))
+(def int-bitwise-or@2 (fun (x y) (@or x y)))
+(def int-bitwise-or@3 (fun (x y z) (@or (@or x y) z)))
+(def int-bitwise-or@4 (fun (x y z t) (@or (@or x y) (@or z t))))
+(def int-bitwise-or int-bitwise-or@2)
+(def int-bitwise-xor (fun (x y) (@xor x y)))
+(def int-bitwise-not (fun (x) (@xor x #x7FFFFFFF)))
+
+;; Return a mask for the n least-significant bits
+(def int-mask
+     (fun (n) (- (int-shift-left 1 n) 1)))
+
+;; Extract n bits from x, starting from bit s
+(def int-extract
+     (fun (x s n)
+          (int-bitwise-and (int-shift-right x s) (int-mask n))))
+
+(def int-even?
+     (fun (i)
+          (= 0 (int-bitwise-and 1 i))))
+
+(def int-odd?
+     (fun (i)
+          (not (int-even? i))))
+
+(def int-abs
+     (fun (i)
+          (if (< i 0) (- i) i)))
+
+(def int-signum
+     (fun (i)
+          (cond ((< i 0) -1)
+                ((= i 0)  0)
+                (#t       1))))
+
+;; Adapted from "Hacker's Delight" by Henry Warren (2nd ed.)
+(def int-count-leading-zeros
+     (fun (i)
+          (if (< i 0)
+              0
+              (rec loop ((i i) (n 31) (c 16))
+                   (if (= 0 c)
+                       (- n i)
+                       (let ((y (@shift-right i c)))
+                         (if (= 0 y)
+                             (loop i n (@shift-right c 1))
+                             (loop y (- n c) (@shift-right c 1)))))))))
+
+;; Floored division
+(def /f
+     (fun (x y)
+          (let ((qt (/t x y)) (rt (%t x y)))
+            (if (= (int-signum rt) (- (int-signum y)))
+                (- qt 1)
+                qt))))
+
+(def %f
+     (fun (x y)
+          (let ((rt (%t x y)))
+            (if (= (int-signum rt) (- (int-signum y)))
+                (+ rt y)
+                rt))))
+
+(def int-gcd
+     (fun (x y)
+          (rec loop ((x (int-abs x))
+                     (y (int-abs y)))
+               (if (= 0 y)
+                   x
+                   (loop y (%t x y))))))
+
+(def int-pow
+     (fun (x y)
+          (rec loop ((x x) (y y))
+               (cond ((= 0 y)
+                      1)
+                     ((int-even? y)
+                      (let ((t (loop x (/t y 2))))
+                        (* t t)))
+                     (#t
+                      (* x (loop x (- y 1))))))))
+
+(def int-read
+     (letrec ((loop
+               (fun (acc-f acc)
+                    (let ((c (char-read)))
+                      (if (char-digit? c)
+                          (loop acc-f (acc-f (* acc 10) (char-digit->int c)))
+                          acc)))))
+       (fun ()
+            (let ((c (char-read)))
+              (cond ((= c '-') (loop - 0))
+                    ((char-digit? c) (loop + (char-digit->int c)))
+                    (#t 0))))))
+
+(def int-print
+     (fun (i)
+          (if (< i 0) (char-print '-'))
+          (rec loop ((i (int-abs i)))
+                    (if (> i 9) (loop (/t i 10)))
+                    (char-print (int->char-digit (%t i 10))))))
+
+(def int->char
+     (fun (i)
+          (@int->char i)))

cs420-acc/l3-warmup/library/integers.l3m

@@ -0,0 +1,2 @@
+characters.l3m
+integers.l3

cs420-acc/l3-warmup/library/lib.l3m

@@ -0,0 +1,14 @@
+;; Main meta-module for the L₃ library.
+
+booleans.l3m
+characters.l3m
+functions.l3m
+integers.l3m
+lists.l3m
+disjoint-sets.l3m
+pairs.l3m
+random.l3m
+strings.l3m
+unit.l3m
+vectors.l3m
+

cs420-acc/l3-warmup/library/lists.l3

@@ -0,0 +1,170 @@
+;; In Emacs, open this file in -*- Scheme -*- mode.
+
+;; (Immutable) lists
+
+(def list?
+     (fun (o)
+          (and (@block? o)
+               (let ((tag (@block-tag o)))
+                 (or (= tag 2) (= tag 3))))))
+
+(def list-empty
+     (@block-alloc-2 0))
+
+(def list-prepend
+     (fun (head tail)
+          (let ((l (@block-alloc-3 2)))
+            (@block-set! l 0 head)
+            (@block-set! l 1 tail)
+            l)))
+
+(def list-empty?
+     (fun (l)
+          (= 2 (@block-tag l))))
+
+(def list-make@1
+     (fun (e1)
+          (list-prepend e1 list-empty)))
+(def list-make@2
+     (fun (e1 e2)
+          (list-prepend e1 (list-make e2))))
+(def list-make@3
+     (fun (e1 e2 e3)
+          (list-prepend e1 (list-make e2 e3))))
+(def list-make@4
+     (fun (e1 e2 e3 e4)
+          (list-prepend e1 (list-make e2 e3 e4))))
+(def list-make@5
+     (fun (e1 e2 e3 e4 e5)
+          (list-prepend e1 (list-make e2 e3 e4 e5))))
+(def list-make@6
+     (fun (e1 e2 e3 e4 e5 e6)
+          (list-prepend e1 (list-make e2 e3 e4 e5 e6))))
+(def list-make@7
+     (fun (e1 e2 e3 e4 e5 e6 e7)
+          (list-prepend e1 (list-make e2 e3 e4 e5 e6 e7))))
+(def list-make@8
+     (fun (e1 e2 e3 e4 e5 e6 e7 e8)
+          (list-prepend e1 (list-make e2 e3 e4 e5 e6 e7 e8))))
+(def list-make@9
+     (fun (e1 e2 e3 e4 e5 e6 e7 e8 e9)
+          (list-prepend e1 (list-make e2 e3 e4 e5 e6 e7 e8 e9))))
+(def list-make@10
+     (fun (e1 e2 e3 e4 e5 e6 e7 e8 e9 e10)
+          (list-prepend e1 (list-make e2 e3 e4 e5 e6 e7 e8 e9 e10))))
+
+(defrec list-tabulate
+  (fun (n f)
+       (rec loop ((i n) (l list-empty))
+            (if (= i 0)
+                l
+                (loop (- i 1) (list-prepend (f (- i 1)) l))))))
+
+(def list-head
+     (fun (l)
+          (@block-get l 0)))
+(def list-tail
+     (fun (l)
+          (@block-get l 1)))
+
+(defrec list-length
+  (fun (l)
+       (if (list-empty? l) 0 (+ 1 (list-length (list-tail l))))))
+
+(def list-for-each
+     (fun (f l)
+          (rec loop ((l l))
+               (if (not (list-empty? l))
+                   (begin
+                     (f (list-head l))
+                     (loop (list-tail l)))))))
+
+(def list-map
+     (fun (f l)
+          (rec loop ((l l))
+               (if (list-empty? l)
+                   l
+                   (list-prepend (f (list-head l)) (loop (list-tail l)))))))
+
+(def list-fold-left
+     (fun (f z l)
+          (rec loop ((z z) (l l))
+               (if (list-empty? l)
+                   z
+                   (loop (f z (list-head l)) (list-tail l))))))
+
+(def list-fold-right
+  (fun (f z l)
+       (rec loop ((z z) (l l))
+            (if (list-empty? l)
+                z
+                (f (list-head l) (loop z (list-tail l)))))))
+
+(def list-every?
+     (fun (p l)
+          (rec loop ((l l))
+               (or (list-empty? l)
+                   (and (p (list-head l))
+                        (loop (list-tail l)))))))
+
+(def list-any?
+     (fun (p l)
+          (rec loop ((l l))
+               (and (not (list-empty? l))
+                    (or (p (list-head l))
+                        (loop (list-tail l)))))))
+
+(def list-filter
+     (fun (p l)
+          (list-fold-right (fun (e r) (if (p e) (list-prepend e r) r))
+                           list-empty
+                           l)))
+
+(def list-partition
+     (fun (p l)
+          (list-fold-right
+           (fun (e y/n)
+                (if (p e)
+                    (pair-make (list-prepend e (pair-fst y/n)) (pair-snd y/n))
+                    (pair-make (pair-fst y/n) (list-prepend e (pair-snd y/n)))))
+           (pair-make list-empty list-empty)
+           l)))
+
+(def list-take
+     (fun (l n)
+          (rec loop ((l l) (n n))
+               (if (or (= 0 n) (list-empty? l))
+                   list-empty
+                   (list-prepend (list-head l) (loop (list-tail l) (- n 1)))))))
+
+(def list-drop
+     (fun (l n)
+          (rec loop ((l l) (n n))
+               (if (or (= 0 n) (list-empty? l))
+                   l
+                   (loop (list-tail l) (- n 1))))))
+
+(def list-nth
+     (fun (l n)
+          (list-head (list-drop l n))))
+
+(def list-reverse
+  (fun (l)
+       (list-fold-left (fun (t h) (list-prepend h t)) list-empty l)))
+
+(def list-append
+     (fun (l1 l2)
+          (rec loop ((l1 l1) (l2 l2))
+               (cond ((list-empty? l1) l2)
+                     ((list-empty? l2) l1)
+                     (#t (list-prepend (list-head l1)
+                                       (loop (list-tail l1) l2)))))))
+
+(def list-zip
+     (fun (l1 l2)
+          (rec loop ((l1 l1) (l2 l2))
+               (if (or (list-empty? l1) (list-empty? l2))
+                   list-empty
+                   (list-prepend
+                    (pair-make (list-head l1) (list-head l2))
+                    (loop (list-tail l1) (list-tail l2)))))))

cs420-acc/l3-warmup/library/lists.l3m

@@ -0,0 +1,3 @@
+integers.l3m
+pairs.l3m
+lists.l3

cs420-acc/l3-warmup/library/pairs.l3

@@ -0,0 +1,34 @@
+;; In Emacs, open this file in -*- Scheme -*- mode.
+
+;; Pairs
+
+(def pair-make (fun (fst snd)
+                    (let ((p (@block-alloc-0 2)))
+                      (@block-set! p 0 fst)
+                      (@block-set! p 1 snd)
+                      p)))
+
+(def pair?
+     (fun (o)
+          (and (@block? o) (= 0 (@block-tag o)))))
+
+(def pair-fst
+     (fun (p)
+          (@block-get p 0)))
+
+(def pair-snd
+     (fun (p)
+          (@block-get p 1)))
+
+(def pair-derive=
+     (fun (fst= snd=)
+          (fun (p1 p2)
+               (and (fst= (pair-fst p1) (pair-fst p2))
+                    (snd= (pair-snd p1) (pair-snd p2))))))
+
+(def pair-derive<
+     (fun (fst< snd<)
+          (fun (p1 p2)
+               (or (fst< (pair-fst p1) (pair-fst p2))
+                   (and (not (fst< (pair-fst p2) (pair-fst p1)))
+                        (snd< (pair-snd p1) (pair-snd p2)))))))

cs420-acc/l3-warmup/library/pairs.l3m

@@ -0,0 +1,2 @@
+integers.l3
+pairs.l3

cs420-acc/l3-warmup/library/random.l3

@@ -0,0 +1,67 @@
+;; In Emacs, open this file in -*- Scheme -*- mode.
+
+;; A PCG random number generator. (Specifically, this is the variant
+;; called XSH RR in the paper, with a 16-bit state and 8-bit output).
+;; See http://www.pcg-random.org/
+
+(def %rng-to-uint16
+     (fun (i) (int-bitwise-and #xFFFF i)))
+
+(def %rng-to-uint8
+     (fun (i) (int-bitwise-and #xFF i)))
+
+(def rng-make
+     (fun (seed)
+          (let ((rng (@block-alloc-50 1)))
+            (@block-set! rng 0 (%rng-to-uint16 seed))
+            rng)))
+
+(def rng?
+     (fun (o)
+          (and (@block? o) (= (@block-tag o) 50))))
+
+(def %rng-get-state
+     (fun (rng)
+          (@block-get rng 0)))
+
+(def %rng-set-state!
+     (fun (rng new-state)
+          (@block-set! rng 0 (%rng-to-uint16 new-state))))
+
+(def %rng-rotate-right-8
+     (fun (x y)
+          (%rng-to-uint8 (int-bitwise-or (int-shift-right x y)
+                                         (int-shift-left x (- 8 y))))))
+
+(def %rng-step
+     (fun (rng)
+          (%rng-set-state! rng (+ (* (%rng-get-state rng) 12829) 47989))))
+
+(def %rng-output
+     (fun (rng)
+          (let ((state (%rng-get-state rng)))
+            (%rng-rotate-right-8
+             (%rng-to-uint8 (int-shift-right
+                             (int-bitwise-xor state (int-shift-right state 5))
+                             5))
+             (int-shift-right state 13)))))
+
+;; Return the next 8-bit unsigned integer (0 to 255, included)
+(def rng-next-int8
+     (fun (rng)
+          (let ((i (%rng-output rng)))
+            (%rng-step rng)
+            i)))
+
+;; FIXME: this is hackish, find a better way to do it (probably using
+;; multiple streams, see sample/pcg32x2-demo.c in the PCG source).
+(def rng-next-int
+     (fun (rng)
+          (let ((b0 (rng-next-int8 rng))
+                (b1 (rng-next-int8 rng))
+                (b2 (rng-next-int8 rng))
+                (b3 (rng-next-int8 rng)))
+            (int-bitwise-or (int-shift-left b0 24)
+                            (int-shift-left b1 16)
+                            (int-shift-left b2 8)
+                            b3))))

cs420-acc/l3-warmup/library/random.l3m

@@ -0,0 +1,2 @@
+integers.l3m
+random.l3

cs420-acc/l3-warmup/library/strings.l3

@@ -0,0 +1,41 @@
+;; In Emacs, open this file in -*- Scheme -*- mode.
+
+;; Strings
+
+(def string?
+     (fun (o)
+          (and (@block? o) (= 200 (@block-tag o)))))
+
+(def string-length
+     (fun (s)
+          (@block-length s)))
+
+(def string-get
+     (fun (s i)
+          (@block-get s i)))
+
+(def string-print
+     (fun (s)
+          (rec loop ((i 0))
+               (if (< i (string-length s))
+                   (begin
+                     (char-print (string-get s i))
+                     (loop (+ i 1)))))))
+
+(def string-concat
+     (fun (s1 s2)
+          (let* ((l1 (string-length s1))
+                 (l2 (string-length s2))
+                 (n (+ l1 l2))
+                 (s (@block-alloc-200 n)))
+            (rec loop ((i 0))
+                 (if (< i l1)
+                     (begin
+                       (@block-set! s i (@block-get s1 i))
+                       (loop (+ i 1)))))
+            (rec loop ((i 0))
+                 (if (< i l2)
+                     (begin
+                       (@block-set! s (+ i l1) (@block-get s2 i))
+                       (loop (+ i 1)))))
+            s)))

cs420-acc/l3-warmup/library/strings.l3m

@@ -0,0 +1,3 @@
+integers.l3m
+characters.l3m
+strings.l3

cs420-acc/l3-warmup/library/unit.l3

@@ -0,0 +1,5 @@
+;; In Emacs, open this file in -*- Scheme -*- mode.
+
+;; Unit
+
+(def unit? (fun (o) (@unit? o)))

cs420-acc/l3-warmup/library/unit.l3m

@@ -0,0 +1 @@
+unit.l3

cs420-acc/l3-warmup/library/vectors.l3

@@ -0,0 +1,148 @@
+;; In Emacs, open this file in -*- Scheme -*- mode.
+
+;; (Mutable) vectors
+
+(def vector-make@1
+     (fun (n)
+          (@block-alloc-1 n)))
+
+(def vector-make@2
+     (fun (n o)
+          (let ((v (@block-alloc-1 n)))
+            (rec loop ((i 0))
+                 (if (< i n)
+                     (begin
+                       (@block-set! v i o)
+                       (loop (+ i 1)))))
+            v)))
+
+(def vector?
+     (fun (o)
+          (and (@block? o) (= 1 (@block-tag o)))))
+
+(def vector-get
+     (fun (v n)
+          (@block-get v n)))
+
+(def vector-set!
+     (fun (v n o)
+          (@block-set! v n o)))
+
+(def vector-length
+     (fun (v)
+          (@block-length v)))
+
+(def vector-fill!
+     (fun (v o)
+          (rec loop ((i 0))
+               (if (< i (vector-length v))
+                   (begin
+                     (vector-set! v i o)
+                     (loop (+ i 1)))))))
+
+(def vector-tabulate
+     (fun (n f)
+          (let ((v (vector-make n)))
+            (rec loop ((i 0))
+                 (if (< i n)
+                     (begin
+                       (vector-set! v i (f i))
+                       (loop (+ i 1)))
+                     v)))))
+
+(def vector-swap!
+     (fun (v i1 i2)
+          (let ((t (vector-get v i1)))
+            (vector-set! v i1 (vector-get v i2))
+            (vector-set! v i2 t))))
+
+(def vector-shuffle!
+     (fun (v rng-seed)
+          (let ((rng (rng-make rng-seed))
+                (l (vector-length v)))
+            (rec loop ((i 0))
+                 (if (< i (- l 1))
+                     (let ((j (+ i (int-abs (%t (rng-next-int rng) (- l i))))))
+                       (vector-swap! v i j)
+                       (loop (+ i 1))))))))
+
+(def %vector-partition!
+     (fun (v p l h)
+          (rec loop ((l l) (h h))
+               (cond ((>= l h)
+                      l)
+                     ((p (vector-get v l))
+                      (loop (+ l 1) h))
+                     ((not (p (vector-get v (- h 1))))
+                      (loop l (- h 1)))
+                     (#t
+                      (vector-swap! v l (- h 1))
+                      (loop (+ l 1) (- h 1)))))))
+
+;; Reorganize the elements of the vector so that all those not
+;; satisfying the predicate [p] are before those that satisfy it.
+;; Return the index of the first element not satisfying [p], or the
+;; length of the vector if all elements satisfy [p].
+(def vector-partition!
+     (fun (v p)
+          (%vector-partition! v p 0 (vector-length v))))
+
+(def vector-fold-left
+     (fun (f z v)
+          (rec loop ((z z) (i 0))
+               (if (= i (vector-length v))
+                   z
+                   (loop (f z (vector-get v i)) (+ i 1))))))
+
+(def vector-for-each
+     (fun (f v)
+          (rec loop ((i 0))
+               (if (< i (vector-length v))
+                   (begin
+                     (f (vector-get v i))
+                     (loop (+ i 1)))))))
+
+(def vector-sort!
+     (fun (v el<)
+          (letrec ((qsort!
+                    (fun (l h)
+                         (if (> (- h l) 0)
+                             (let* ((p (vector-get v h))
+                                    (<p (fun (x) (el< x p)))
+                                    (m (%vector-partition! v <p l h)))
+                               (vector-swap! v m h)
+                               (qsort! l (- m 1))
+                               (qsort! (+ m 1) h))))))
+            (qsort! 0 (- (vector-length v) 1)))))
+
+(def vector-binary-search
+     (fun (v e el<)
+          (rec loop ((l 0) (h (- (vector-length v) 1)))
+               (if (> l h)
+                   (- -1 l)
+                   (let* ((m (+ l (/t (- h l) 2)))
+                          (me (vector-get v m)))
+                     (cond ((el< e me)
+                            (loop l (- m 1)))
+                           ((el< me e)
+                            (loop (+ m 1) h))
+                           (#t
+                            m)))))))
+
+(def vector->list
+     (fun (v)
+          (rec loop ((i (- (vector-length v) 1)))
+               (if (= i -1)
+                   list-empty
+                   (list-prepend (vector-get v i) (loop (- i 1)))))))
+
+(def list->vector
+     (fun (l)
+          (let* ((n (list-length l))
+                 (v (vector-make n)))
+            (rec loop ((i 0) (l l))
+                 (if (< i n)
+                     (begin
+                       (vector-set! v i (list-head l))
+                       (loop (+ i 1) (list-tail l)))
+                     v)))))

cs420-acc/l3-warmup/library/vectors.l3m

@@ -0,0 +1,4 @@
+integers.l3m
+lists.l3m
+random.l3m
+vectors.l3