glisp/lisp/kernel.gl

;; -*- mode: lisp-data -*-

;; Defining macros and functions
(fset 'defmacro
      (cons 'macro
            (lambda (name lambda-list &rest body)
              "Define NAME to be a macro."
              (declare (name defmacro))
              (list 'fset (list 'quote name)
                    (list 'cons
                          (quote 'macro)
                          (list 'lambda lambda-list
                                (list 'declare (list 'name name))
                                (list* 'block name
                                       body)))))))

(defmacro defun (name lambda-list &rest body)
  "Define NAME to be a function."
  (list 'fset (list 'quote name)
        (list 'lambda lambda-list
              (list 'declare (list 'name name))
              (list* 'block name
                     body))))

;; List indicies
(defun first (list)
  "Return the first element of LIST."
  (car list))
(defun second (list)
  "Return the second element of LIST."
  (car (cdr list)))
(defun third (list)
  "Return the third element of LIST."
  (car (cdr (cdr list))))
(defun fourth (list)
  "Return the fourth element of LIST."
  (car (cdr (cdr (cdr list)))))
(defun fifth (list)
  "Return the fifth element of LIST."
  (car (cdr (cdr (cdr (cdr list))))))
(defun sixth (list)
  "Return the sixth element of LIST."
  (car (cdr (cdr (cdr (cdr (cdr list)))))))
(defun seventh (list)
  "Return the seventh element of LIST."
  (car (cdr (cdr (cdr (cdr (cdr (cdr list))))))))
(defun eighth (list)
  "Return the eighth element of LIST."
  (car (cdr (cdr (cdr (cdr (cdr (cdr (cdr list)))))))))
(defun ninth (list)
  "Return the ninth element of LIST."
  (car (cdr (cdr (cdr (cdr (cdr (cdr (cdr (cdr list))))))))))
(defun tenth (list)
  "Return the tenth element of LIST."
  (car (cdr (cdr (cdr (cdr (cdr (cdr (cdr (cdr (cdr list)))))))))))

;; Utility macros
(defmacro when (cond &rest body)
  "Evaluate BODY if COND evaluates to non-nil."
  (list 'if cond
        (cons 'progn body)))

(defmacro unless (cond &rest body)
  "Evaluate BODY if COND evaluates to nil."
  (list* 'if cond
        nil
        body))

(defmacro dolist (spec &rest body)
  "Evaluate BODY for each element of a list.
Spec is of the form (VARIABLE LIST &optional RETURN-FORM)."
  (unless (and (or (length= spec 2) (length= spec 3))
               (symbolp (car spec)))
    (signal 'error (list spec)))
  (let ((list-var (make-symbol "--dolist-list--"))
        (cur-var (make-symbol "--dolist-cur--")))
    (list 'let (list (list list-var (second spec))
                     cur-var)
          (list 'while list-var
                (list 'setq cur-var (list 'car list-var))
                (list* 'let (list (list (first spec) cur-var))
                       body)
                (list 'setq list-var (list 'cdr list-var)))
          (when (third spec)
            (list 'let (list (list (first spec) cur-var))
                  (third spec))))))

;; List functions
(defun mapcar (function list)
  "Apply FUNCTION to each element of LIST and return a list of the results."
  (let (start end)
    (dolist (elt list)
      (let ((res (funcall function elt)))
        (if (null start)
            (progn
              (setq start (list res)
                    end start))
          (rplacd end (list res))
          (setq end (cdr end)))))
    start))

(defun mapc (function list)
  "Apply FUNCTION to each element of LIST, then return LIST."
  (dolist (elt list list)
    (funcall function elt)))

;; Functional functions
(defun identity (x)
  "Return X."
  x)

(defun complement (f)
  "Return the complement function of F, that is (not (f))."
  (lambda (&rest r)
    (not (apply f r))))

;; Some other functions
(defun terpri (&optional print-char-fun)
  "Print a newline to PRINT-CHAR-FUN, then flush it."
  (let ((fun (or print-char-fun #'write-byte)))
    (funcall fun ?\n)
    (funcall fun nil)))

(defun prin1ln (datum &optional print-char-fun)
  "`prin1' DATUM to PRINT-CHAR-FUN, then do a `terpri'."
  (prin1 datum print-char-fun)
  (terpri print-char-fun))

(defun princln (datum &optional print-char-fun)
  "`princ' DATUM to PRINT-CHAR-FUN, then do a `terpri'."
  (princ datum print-char-fun)
  (terpri print-char-fun))

;; Cond
(defun internal-expand-single-cond (cond)
  (if (cdr cond)
      (let ((res (list 'if (car cond)
                       (list* 'progn (cdr cond)))))
        (cons res res))
    (let* ((res-var (make-symbol "res"))
           (if-stmt (list 'if res-var res-var)))
      (cons (list 'let (list (list res-var (car cond)))
                  if-stmt)
            if-stmt))))

(defmacro cond (&rest conds)
  (let (out last-if)
    (dolist (cond conds)
      (let ((res (internal-expand-single-cond cond)))
        (if (not out)
            (setq out (car res)
                  last-if (cdr res))
          (rplacd (last last-if) (list (car res)))
          (setq last-if (cdr res)))))
    out))

;; Type predicates
(defmacro define-type-predicate (name args &rest body)
  (cond
   ((eq args 'alias)
    (let ((var (make-symbol "var")))
      (list 'put (list 'quote name) ''type-predicate
            (list 'lambda (list var) (list 'typep var (cons 'quote body))))))
   ((and (symbolp args) (null body))
    (list 'put (list 'quote name) ''type-predicate (list 'quote args)))
   (t
    (list 'put (list 'quote name) ''type-predicate
          (list 'lambda args
                (list 'declare (list 'name name))
                (list* 'block name
                       body))))))

(defun typep (obj type)
  (let* ((name (if (consp type)
                   (car type)
                 type))
         (pred (get name 'type-predicate))
         (args (and (consp type) (cdr type))))
    (unless pred
      (throw 'type-error))
    (apply pred obj args)))

(define-type-predicate t (obj) t)
(define-type-predicate any alias t)
(define-type-predicate or (obj &rest preds)
  (dolist (pred preds)
    (let ((res (typep obj pred)))
      (when res
        (return-from or res))))
  nil)
(define-type-predicate and (obj &rest preds)
  (let (res)
    (dolist (pred preds)
      (unless (setq res (typep obj pred))
        (return-from and nil)))
    res))
(define-type-predicate pred (obj pred)
  (funcall pred obj))
(define-type-predicate null null)
(define-type-predicate string stringp)
(define-type-predicate symbol symbolp)
(define-type-predicate cons consp)
(define-type-predicate list listp)
(define-type-predicate integer (obj &opt min max)
  (and (integerp obj)
       (or (not min) (>= obj min))
       (or (not max) (<= obj max))))
(define-type-predicate fixnum fixnump)
(define-type-predicate bignum bignump)
(define-type-predicate byte alias (integer -128 127))
(define-type-predicate signed-byte alias byte)
(define-type-predicate unsigned-byte alias (integer 0 255))
(define-type-predicate float (obj &opt min max)
  (and (floatp obj)
       (or (not min) (>= obj min))
       (or (not max) (<= obj max))))
(define-type-predicate vector vectorp)
(define-type-predicate function functionp)
(define-type-predicate callable callablep)
(define-type-predicate hash-table hash-table-p)
(define-type-predicate user-pointer user-pointer-p)
(define-type-predicate record recordp)
(define-type-predicate number (obj &opt min max)
  (typep obj (list 'or (list 'float min max)
                   (list 'integer min max))))

(princln (typep [] '(or vector list)))