import flatrate lisp, rename to Universal Service LISP

1 files changed, 264 insertions, 0 deletions

diff --git a/examples/lisp/prelude.scm b/examples/lisp/prelude.scm
new file mode 100644
index 0000000..b181e34
--- /dev/null
+++ b/examples/lisp/prelude.scm
@@ -0,0 +1,264 @@
+; Copyright (c) 2024, Peter McGoron
+;
+; Redistribution and use in source and binary forms, with or without
+; modification, are permitted provided that the following conditions
+; are met:
+;
+; 1) Redistributions of source code must retain the above copyright
+;    notice, this list of conditions and the following disclaimer.
+; 2) Redistributions in binary form must reproduce the above copyright
+;    notice, this list of conditions and the following disclaimer in the
+;    documentation and/or other materials provided with the distribution.
+;
+; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
+; TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
+; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
+; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
+; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+; Primitives are special syntatic forms. They differ from built-in
+; functions.
+;
+; primitives:
+; __lambda: lambda of one argument
+; __define: define in the environment
+; __define-macro: Like __define but for macros
+; set!
+; if
+;
+; Others:
+; __uniapply: Apply function to single argument
+; <undefined>: A value that can only be passed to __lambda. It cannot
+;              be bound to a top-level, or "set!", or added to a list.
+;              It can also be the parameter of a __lambda, although
+;              it still cannot be used.
+;
+; Macros are functions that return an sexpr.
+
+(__define-macro let
+ (__lambda l ; car = args, cdr = body
+  (if (null? (car args))
+      (cdr args)
+      ; (car args) = ((A a) (B b) ...)
+      ; (car (car args)) = (A a)
+      ; (cdr (car (car args))) = (a)
+      `((__lambda ,(car (car (car args)))
+                     (let ,(cdr (car args)) ,@body))
+        ,@(car (cdr (car (car args))))
+       )
+  )
+ )
+)
+
+(__define-macro let* let)
+
+; if and __lambda only execute one statement.
+(__define-macro begin body
+ (let ((first (car body))
+       (rest (cdr body))
+      )
+  (if (null? rest)
+      first
+      `((__lambda <undefined> (begin ,@rest)) ,first)
+  )
+ )
+)
+
+;;; (cond (case1 expr1) (case2 expr2) ... (else exprelse))
+(__define-macro cond body
+ (let ((cases (car body)))
+  (if (null? body)
+      <undefined>
+      (let* ((branch (car cases))
+             (rest (cdr cases))
+             (test (car branch))
+             (to-exec (cdr branch))
+            )
+       (if (null? to-exec)
+           (let ((tmp (gensym)))
+            `(let ((,tmp ,test))
+              (if ,tmp ,tmp (cond ,@rest))
+             )
+           )
+           (if (eqv? test 'else)
+               (if (null? rest)
+                   `(begin ,@rest)
+                   (error "invalid else clause")
+               )
+               (if (eqv? (car to-exec) '=>)
+                   (let ((tmp (gensym))
+                         (fun (cdr to-exec))
+                        )
+                    `(let ((,tmp ,test))
+                      (if ,tmp (,fun ,tmp) (cond ,@rest))
+                     )
+                   )
+                   `(if ,tmp (begin ,@rest) (cond ,@rest))
+               )
+           )
+       )
+      )
+  )
+ )
+)
+
+(__define-macro __bindlambda
+ (__lambda l
+  (let ((larg (car l))
+        (args (car (cdr l)))
+        (body (cdr (cdr l)))
+       )
+   (if (null? args)
+       `(__lambda larg
+         (if (not (null? larg))
+             (raise "incorrect number of arguments")
+             (begin ,@body)
+         )
+        )
+       (let* ((argval (cons args))
+              (rest (cdr args))
+              (arg (cons argval))
+              (val (cons (cdr argval)))
+             )
+       `(__lambda ,larg
+         (let ((,arg ,val)) __bindlambda ,larg ,rest ,@body)
+        )
+       )
+   )
+  )
+ )
+)
+
+(__define-macro lambda
+ (__lambda l
+  (let ((args (car l))
+        (body (cdr l))
+       )
+   (if (symbol? args)
+       `(__lambda ,args (begin ,@body))
+       (if (null? args)
+           `(__lambda <undefined> (begin ,@body))
+           (let ((larg (gensym)))
+             `(__bindlambda ,larg ,@body)
+           )
+       )
+   )
+  )
+ )
+)
+
+(__define-macro define-macro
+ (__lambda l
+  (let* ((name-and-args (car l))
+         (name (car name-and-args))
+         (args (cdr name-and-args))
+         (body (cdr l))
+         (tmpname (gensym))
+        )
+   `(__define-macro ,name
+     (lambda ,args ,@body)
+    )
+  )
+ )
+)
+
+(define-macro (and . body)
+ (if (null? body)
+     1
+     (let ((first (car body))
+           (rest (cdr body))
+          )
+      `(if ,first (and ,@rest) 0)
+     )
+ )
+)
+
+(define-macro (or . body)
+ (if (null? body)
+     0
+     (let ((first (car body))
+           (rest (cdr body))
+          )
+      `(if ,first 1 (or ,@rest))
+     )
+ )
+)
+
+(define-macro (letrec args . body)
+ (if (null? args)
+     body
+     (let* ((argval (car args))
+            (arg (car argval))
+            (val (car (cdr argval)))
+            (rest (cdr args))
+           )
+     `(let ((,arg <undefined>))
+       (letrec ,rest (begin (set! ,arg ,val) ,@body))
+      )
+     )
+ )
+)
+
+(define-macro (define name . body)
+ (if (symbol? name)
+     `(__define ,name ,@body)
+     (let ((fname (car name))
+           (args (cdr name))
+           (tmparg (gensym))
+          )
+      `(__define ,fname
+        (lambda ,tmparg
+         (letrec ((,fname (lambda ,args ,@body)))
+          (,fname . ,tmparg)
+         )
+       )
+     )
+    )
+ )
+)
+
+;;;;;;;;;;;;;; Standard Library ;;;;;;;;;;;;;;;;;;;
+
+;; for a list of (v1 v2 ... vn)
+;; runs (f vn (... (f v2 (f v1 start))))
+(define (foldl f start l)
+ (letrec
+  ((loop 
+    (lambda (ret-list cur-list)
+     (if (eqv? value '())
+         value
+         (loop (f (car cur-list) value)
+               (cdr cur-list))
+     )
+    )
+  ))
+  (loop start l)
+ )
+)
+
+(define (reverse l) (foldl cons '() l))
+
+;; for a list of (v1 v2 ... vn)
+;; runs (f v1 (f v2 (... (f vn start))))
+(define (foldr f start l) (foldl f start (reverse l)))
+
+(define (append . l)
+ (foldr (lambda (to-prepend collected)
+         (foldr cons collected to-prepend)
+        )
+        '()
+        l
+ )
+)
+
+(define (apply f . l) (__uniapply f (__uniapply append l)))
+(define (list . l) l)
+
+;; (define (+ . l) (foldl __bin+ 0 l))
+;; (define (* . l) (foldl __bin* 1 l))