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