test.lisp

   1 ;;; Library
   2
   3 (eval-when-compile
   4   (%compile-defmacro 'defmacro
   5      (lambda (name args &rest body)
   6        `(eval-when-compile
   7           (%compile-defmacro ',name (lambda ,args ,@body))))))
   8
   9 (defmacro defvar (name value)
  10   `(progn
  11      (eval-when-compile
  12        (%compile-defvar ',name))
  13      (setq ,name ,value)))
  14
  15 (defvar t 't)
  16 (defvar nil 'nil)
  17
  18 (defmacro defun (name args &rest body)
  19   `(progn
  20      (eval-when-compile
  21        (%compile-defun ',name))
  22      (fsetq ,name (lambda ,args ,@body))))
  23
  24 (defun = (x y) (= x y))
  25 (defun + (x y) (+ x y))
  26 (defun - (x y) (- x y))
  27 (defun * (x y) (* x y))
  28 (defun / (x y) (/ x y))
  29 (defun 1+ (x) (+ x 1))
  30 (defun 1- (x) (- x 1))
  31 (defun zerop (x) (= x 0))
  32 (defun not (x) (if x nil t))
  33
  34 (defun truncate (x y) (floor (/ x y)))
  35
  36 (defun cons (x y ) (cons x y))
  37 (defun car (x) (car x))
  38 (defun caar (x) (car (car x)))
  39 (defun cadr (x) (car (cdr x)))
  40 (defun cdr (x) (cdr x))
  41 (defun cdar (x) (cdr (car x)))
  42 (defun cddr (x) (cdr (cdr x)))
  43
  44 (defun append (list1 list2)
  45   (if (null list1)
  46       list2
  47       (cons (car list1)
  48             (append (cdr list1) list2))))
  49
  50 (defun reverse-aux (list acc)
  51   (if (null list)
  52       acc
  53       (reverse-aux (cdr list) (cons (car list) acc))))
  54
  55 (defun reverse (list)
  56   (reverse-aux list '()))
  57
  58 (defmacro incf (x)
  59   `(setq ,x (1+ ,x)))
  60
  61 (defmacro decf (x)
  62   `(setq ,x (1- ,x)))
  63
  64 (defun length (list)
  65   (let ((l 0))
  66     (while (not (null list))
  67       (incf l)
  68       (setq list (cdr list)))
  69     l))
  70
  71 (defun mapcar (func list)
  72   (if (null list)
  73       '()
  74       (cons (funcall func (car list))
  75             (mapcar func (cdr list)))))
  76
  77 (defmacro push (x place)
  78   `(setq ,place (cons ,x ,place)))
  79
  80 (defvar *package* (new))
  81
  82 (defun intern (name)
  83   (let ((s (get *package* name)))
  84     (if s
  85         s
  86         (set *package* name (make-symbol name)))))
  87
  88 (defun find-symbol (name)
  89   (get *package* name))
  90
  91
  92 (defmacro cond (&rest clausules)
  93   (if (null clausules)
  94       nil
  95       (if (eq (caar clausules) t)
  96           `(progn ,@(cdar clausules))
  97           `(if ,(caar clausules)
  98                (progn ,@(cdar clausules))
  99                (cond ,@(cdr clausules))))))
 100
 101 (defun !reduce (func list initial)
 102   (if (null list)
 103       initial
 104       (!reduce func
 105                (cdr list)
 106                (funcall func initial (car list)))))
 107
 108
 109 (defun code-char (x) x)
 110 (defun char-code (x) x)
 111 (defvar *newline* (string (code-char 10)))
 112
 113 (defun concat (&rest strs)
 114   (!reduce (lambda (s1 s2) (concat-two s1 s2))
 115            strs
 116            ""))
 117
 118 ;;; Concatenate a list of strings, with a separator
 119 (defun join (list separator)
 120   (cond
 121     ((null list)
 122      "")
 123     ((null (cdr list))
 124      (car list))
 125     (t
 126      (concat (car list)
 127              separator
 128              (join (cdr list) separator)))))
 129
 130 (defun join-trailing (list separator)
 131   (if (null list)
 132       ""
 133       (concat (car list) separator (join-trailing (cdr list) separator))))
 134
 135 (defun integer-to-string (x)
 136   (if (zerop x)
 137       "0"
 138       (let ((digits nil))
 139         (while (not (zerop x 0))
 140           (push (mod x 10) digits)
 141           (setq x (truncate x 10)))
 142         (join (mapcar (lambda (d) (string (char "0123456789" d)))
 143                       digits)
 144               ""))))
 145
 146 (defmacro and (&rest forms)
 147   (cond
 148     ((null forms)
 149      t)
 150     ((null (cdr forms))
 151      (car forms))
 152     (t
 153      `(if ,(car forms)
 154           (and ,@(cdr forms))
 155           nil))))
 156
 157
 158 (defmacro or (&rest forms)
 159   (cond
 160     ((null forms)
 161      nil)
 162     ((null (cdr forms))
 163      (car forms))
 164     (t
 165      `(if ,(car forms)
 166           t
 167           (or ,@(cdr forms))))))
 168
 169
 170 (defmacro prog1 (form &rest body)
 171   (let ((value (make-symbol "VALUE")))
 172     `(let ((,value ,form))
 173        ,@body
 174        ,value)))
 175
 176
 177 (defun char= (x y) (= x y))
 178
 179
 180 ;;;; Reader
 181
 182 ;;; It is a basic Lisp reader. It does not use advanced stuff
 183 ;;; intentionally, because we want to use it to bootstrap a simple
 184 ;;; Lisp. The main entry point is the function `ls-read', which
 185 ;;; accepts a strings as argument and return the Lisp expression.
 186 (defun make-string-stream (string)
 187   (cons string 0))
 188
 189 (defun %peek-char (stream)
 190   (and (< (cdr stream) (length (car stream)))
 191        (char (car stream) (cdr stream))))
 192
 193 (defun %read-char (stream)
 194   (and (< (cdr stream) (length (car stream)))
 195        (prog1 (char (car stream) (cdr stream))
 196          (setcdr stream (1+ (cdr stream))))))
 197
 198 (defun whitespacep (ch)
 199   (or (char= ch #\space) (char= ch #\newline) (char= ch #\tab)))
 200
 201 (defun skip-whitespaces (stream)
 202   (let (ch)
 203     (setq ch (%peek-char stream))
 204     (while (and ch (whitespacep ch))
 205       (%read-char stream)
 206       (setq ch (%peek-char stream)))))
 207
 208 (defun terminalp (ch)
 209   (or (null ch) (whitespacep ch) (char= #\) ch) (char= #\( ch)))
 210
 211
 212 (defun read-until (stream func)
 213   (let ((string "")
 214         (ch))
 215     (setq ch (%peek-char stream))
 216     (while (not (funcall func ch))
 217       (setq string (concat string (string ch)))
 218       (%read-char stream)
 219       (setq ch (%peek-char stream)))
 220     string))
 221
 222 (defun skip-whitespaces-and-comments (stream)
 223   (let (ch)
 224     (skip-whitespaces stream)
 225     (setq ch (%peek-char stream))
 226     (while (and ch (char= ch #\;))
 227       (read-until stream (lambda (x) (char= x #\newline)))
 228       (skip-whitespaces stream)
 229       (setq ch (%peek-char stream)))))