Add even?, odd?.
[mes.git] / module / mes / scm.mes
index 3dcd5e6fd5b5c01c7737b93cd2e727d86fc54f76..7861f05ff8c062517d14de7452a2b25d89d18b67 100644 (file)
@@ -3,7 +3,7 @@
 ;;; Mes --- Maxwell Equations of Software
 ;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
 ;;;
-;;; scm.mes: This file is part of Mes.
+;;; This file is part of Mes.
 ;;;
 ;;; Mes is free software; you can redistribute it and/or modify it
 ;;; under the terms of the GNU General Public License as published by
 
 ;;; Code:
 
+(mes-use-module (mes let))
+
 (define (cadddr x) (car (cdddr x)))
 
 (define (list . rest) rest)
 
+(define (list-head x n)
+  (if (= 0 n) '()
+      (cons (car x) (list-head (cdr x) (- n 1)))))
+
+(define (list-tail x n)
+  (if (= 0 n) x
+      (list-tail (cdr x) (- n 1))))
+
+(define (string-prefix? prefix string)
+  (and
+   (>= (string-length string) (string-length prefix))
+   (equal? (substring string 0 (string-length prefix)) prefix)))
+
+(define (symbol-prefix? prefix symbol)
+  (string-prefix? (symbol->string prefix) (symbol->string symbol)))
+
+(define (symbol-append . rest)
+  (string->symbol (apply string-append (map symbol->string rest))))
+
 (define-macro (case val . args)
-  (if (null? args)
-      #f
-      (let* ((clause (car args))
-             (pred (car clause))
-             (body (cdr clause)))
-        (if (pair? pred)
-            `(if ,(if (null? (cdr pred))
-                      `(eq? ,val ',(car pred))
-                           `(member ,val ',pred))
-                 (begin ,@body)
-                 (case ,val ,@(cdr args)))
-            `(begin ,@body)))))
+  (if (null? args) #f
+      (let ((clause (car args)))
+        (let ((pred (car clause)))
+          (let ((body (cdr clause)))
+           (if (pair? pred) `(if ,(if (null? (cdr pred))
+                                      `(eq? ,val ',(car pred))
+                                      `(member ,val ',pred))
+                                 (begin ,@body)
+                                 (case ,val ,@(cdr args)))
+               `(begin ,@body)))))))
 
 (define-macro (when expr . body)
   `(if ,expr
           (cons (string-ref s i) (loop (+ i 1)))))))
 
 (define (vector . rest) (list->vector rest))
+(define c:make-vector make-vector)
 (define (make-vector n . x)
-  (list->vector (apply make-list (cons n x))))
+  (if (null? x) (c:make-vector n)
+      (list->vector (apply make-list (cons n x)))))
 
 (define (acons key value alist)
   (cons (cons key value) alist))
           (member x (cdr lst)))))
 
 (define (for-each f l . r)
-  (if (null? l) '() ;; IF
-      (if (null? r) (begin (f (car l)) (for-each f (cdr l)))
-          (if (null? (cdr r))
-              (for-each f (cdr l) (cdar r))))))
+  (if (pair? l) (if (null? r) (begin (f (car l)) (for-each f (cdr l)))
+                    (if (null? (cdr r)) (begin (f (car l) (caar r)) (for-each f (cdr l) (cdar r)))))))
 
 (define (<= . rest)
   (or (apply < rest)
 (define (remainder x y)
   (- x (* (quotient x y) y)))
 
+(define (even? x)
+  (= 0 (remainder x 2)))
+
+(define (odd? x)
+  (= 1 (remainder x 2)))
+
 (define (expt x y)
   (let loop ((s 1) (count y))
     (if (= 0 count) s
 
 (define (max x . rest)
   (if (null? rest) x
-      (let* ((y (car rest))
-             (z (if (> x y) x y)))
-        (apply max (cons z (cdr rest))))))
+      (let ((y (car rest)))
+        (let ((z (if (> x y) x y)))
+          (apply max (cons z (cdr rest)))))))
 
 (define (min x . rest)
   (if (null? rest) x
-      (let* ((y (car rest))
-             (z (if (< x y) x y)))
-        (apply min (cons z (cdr rest))))))
+      (let ((y (car rest)))
+        (let ((z (if (< x y) x y)))
+          (apply min (cons z (cdr rest)))))))
 
 (define gensym
   (let ((counter 0))
   (display who (current-error-port))
   (display ":" (current-error-port))
   (display rest (current-error-port))
-  (newline (current-error-port)))
+  (newline (current-error-port))
+  (display "exiting...\n" (current-error-port))
+  (exit 1))
 
 (define (syntax-error message . rest)
   (display "syntax-error:" (current-error-port))