Flatrate/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:
; __unilambda: lambda of one argument
; __define: define in the environment
; __define-macro: Like __define but for macros
; set!
; __exec: apply an argument to a lambda and return it to the continuation.
; __continue-if: continuation version of if.
;
; Others:
; <undefined>: A value that can only be passed to __unilambda. It cannot
;              be bound to a top-level, or "set!", or added to a list.
;              It can also be the parameter of a __unilambda, although
;              it still cannot be used.
;
; Macros are functions that return an sexpr.

(__define-macro if
 (__unilambda l
  (__continue-if (car l)
                 (__unilambda <undefined> (car (cdr l)))
                 (__unilambda <undefined> (car (cdr (cdr l))))
  )
 )
)

(__define-macro let
 (__unilambda 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)
      `(__exec (__unilambda <undefined> ,(car (cdr (car (car args)))))
               <undefined>
               (__unilambda ,(car (car (car args)))
                            (let ,(cdr (car args)) ,@body)
               )
       )
  )
 )
)

(__define-macro let* let)

; if and __unilambda only execute one statement.
(__define-macro begin body
 (let ((first (car body))
       (rest (cdr body))
      )
  (if (null? rest)
      first
      `(__exec (__unilambda <undefined> ,first)
               <undefined>
               (__unilambda <undefined> (begin ,@rest))
       )
  )
 )
)

(__define-macro __bindlambda
 (__unilambda l
  (let ((larg (car l))
        (args (car (cdr l)))
        (body (cdr (cdr l)))
       )
   (if (null? args)
       `(__unilambda larg
         (if (not (null? larg))
             (raise "incorrect number of arguments")
             (begin ,@body)
         )
        )
       (if (symbol? args)
           `(__unilambda ,args ,@body)
            (let* ((argval (cons args))
                   (rest (cdr args))
                   (arg (cons argval))
                   (val (cons (cdr argval)))
                  )
            `(__unilambda ,larg
              (let ((,arg ,val)) __bindlambda ,larg ,rest ,@body)
             )
            )
       )
   )
  )
 )
)

(__define-macro lambda
 (__unilambda l
  (let ((args (car l))
        (body (cdr l))
       )
   (if (symbol? args)
       `(__unilambda ,args ,@body)
       (if (null? args)
           `(__unilambda <undefined> (begin ,@body))
           (let ((larg (gensym)))
             `(__bindlambda ,larg ,@body)
           )
       )
   )
  )
 )
)

(__define-macro define-macro
 (lambda (name-and-args . body)
  (let ((name (car name-and-args))
        (args (cdr name-and-args))
        (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 ;;;;;;;;;;;;;;;;;;;

(define (call-with-current-continuation f)
 (f (current-continuation))
)
(define call/cc call-with-current-continuation)

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