universalservice/examples/lisp/prelude.scm

; 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))