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 list (&rest args)
  51   args)
  52
  53 (defun append (list1 list2)
  54   (if (null list1)
  55       list2
  56       (cons (car list1)
  57             (append (cdr list1) list2))))
  58
  59 (defun reverse-aux (list acc)
  60   (if (null list)
  61       acc
  62       (reverse-aux (cdr list) (cons (car list) acc))))
  63
  64 (defun reverse (list)
  65   (reverse-aux list '()))
  66
  67 (defmacro incf (x)
  68   `(setq ,x (1+ ,x)))
  69
  70 (defmacro decf (x)
  71   `(setq ,x (1- ,x)))
  72
  73 (defun length (list)
  74   (let ((l 0))
  75     (while (not (null list))
  76       (incf l)
  77       (setq list (cdr list)))
  78     l))
  79
  80 (defun mapcar (func list)
  81   (if (null list)
  82       '()
  83       (cons (funcall func (car list))
  84             (mapcar func (cdr list)))))
  85
  86 (defmacro push (x place)
  87   `(setq ,place (cons ,x ,place)))
  88
  89 (defvar *package* (new))
  90
  91 (defun intern (name)
  92   (let ((s (get *package* name)))
  93     (if s
  94         s
  95         (set *package* name (make-symbol name)))))
  96
  97 (defun find-symbol (name)
  98   (get *package* name))
  99
 100
 101 (defmacro cond (&rest clausules)
 102   (if (null clausules)
 103       nil
 104       (if (eq (caar clausules) t)
 105           `(progn ,@(cdar clausules))
 106           `(if ,(caar clausules)
 107                (progn ,@(cdar clausules))
 108                (cond ,@(cdr clausules))))))
 109
 110
 111 (defmacro case (form &rest clausules)
 112   (let ((!form (make-symbol "FORM")))
 113     `(let ((,!form ,form))
 114        (cond
 115          ,@(mapcar (lambda (clausule)
 116                      (if (eq (car clausule) t)
 117                          clausule
 118                          `((eql ,!form ,(car clausule))
 119                            ,@(cdr clausule))))
 120                    clausules)))))
 121
 122 (defmacro ecase (form &rest clausules)
 123   `(case ,form
 124      ,@(append
 125         clausules
 126         `((t
 127            (error "ECASE expression failed."))))))
 128
 129 (defun !reduce (func list initial)
 130   (if (null list)
 131       initial
 132       (!reduce func
 133                (cdr list)
 134                (funcall func initial (car list)))))
 135
 136
 137 (defun code-char (x) x)
 138 (defun char-code (x) x)
 139 (defvar *newline* (string (code-char 10)))
 140
 141 (defun concat (&rest strs)
 142   (!reduce (lambda (s1 s2) (concat-two s1 s2))
 143            strs
 144            ""))
 145
 146 ;;; Concatenate a list of strings, with a separator
 147 (defun join (list separator)
 148   (cond
 149     ((null list)
 150      "")
 151     ((null (cdr list))
 152      (car list))
 153     (t
 154      (concat (car list)
 155              separator
 156              (join (cdr list) separator)))))
 157
 158 (defun join-trailing (list separator)
 159   (if (null list)
 160       ""
 161       (concat (car list) separator (join-trailing (cdr list) separator))))
 162
 163 (defun integer-to-string (x)
 164   (if (zerop x)
 165       "0"
 166       (let ((digits nil))
 167         (while (not (zerop x 0))
 168           (push (mod x 10) digits)
 169           (setq x (truncate x 10)))
 170         (join (mapcar (lambda (d) (string (char "0123456789" d)))
 171                       digits)
 172               ""))))
 173
 174 (defmacro and (&rest forms)
 175   (cond
 176     ((null forms)
 177      t)
 178     ((null (cdr forms))
 179      (car forms))
 180     (t
 181      `(if ,(car forms)
 182           (and ,@(cdr forms))
 183           nil))))
 184
 185
 186 (defmacro or (&rest forms)
 187   (cond
 188     ((null forms)
 189      nil)
 190     ((null (cdr forms))
 191      (car forms))
 192     (t
 193      `(if ,(car forms)
 194           t
 195           (or ,@(cdr forms))))))
 196
 197
 198 (defmacro prog1 (form &rest body)
 199   (let ((value (make-symbol "VALUE")))
 200     `(let ((,value ,form))
 201        ,@body
 202        ,value)))
 203
 204
 205 (defun char= (x y) (= x y))
 206
 207
 208 (defun digit-char-p (x)
 209   (if (and (< #\0 x) (< x #\9))
 210       (- x #\0)
 211       nil))
 212
 213 (defun parse-integer (string)
 214   (let ((value 0)
 215         (index 0)
 216         (size (string-length string)))
 217     (while (< index size)
 218       (setq value (+ (* value 10) (digit-char-p (char string index))))
 219       (incf index))))
 220
 221 (defun every (function seq)
 222   ;; string
 223   (let ((ret t)
 224         (index 0)
 225         (size (string-length seq)))
 226     (while (and ret (< index size))
 227       (unless (funcall function (char seq index))
 228         (setq ret nil)))))
 229
 230 (defun eql (x y)
 231   (eq x y))
 232
 233 (defun string= (s1 s2)
 234   (equal s1 s2))
 235
 236 ;;;; Reader
 237
 238 ;;; It is a basic Lisp reader. It does not use advanced stuff
 239 ;;; intentionally, because we want to use it to bootstrap a simple
 240 ;;; Lisp. The main entry point is the function `ls-read', which
 241 ;;; accepts a strings as argument and return the Lisp expression.
 242 (defun make-string-stream (string)
 243   (cons string 0))
 244
 245 (defun %peek-char (stream)
 246   (and (< (cdr stream) (length (car stream)))
 247        (char (car stream) (cdr stream))))
 248
 249 (defun %read-char (stream)
 250   (and (< (cdr stream) (length (car stream)))
 251        (prog1 (char (car stream) (cdr stream))
 252          (setcdr stream (1+ (cdr stream))))))
 253
 254 (defun whitespacep (ch)
 255   (or (char= ch #\space) (char= ch #\newline) (char= ch #\tab)))
 256
 257 (defun skip-whitespaces (stream)
 258   (let (ch)
 259     (setq ch (%peek-char stream))
 260     (while (and ch (whitespacep ch))
 261       (%read-char stream)
 262       (setq ch (%peek-char stream)))))
 263
 264 (defun terminalp (ch)
 265   (or (null ch) (whitespacep ch) (char= #\) ch) (char= #\( ch)))
 266
 267
 268 (defun read-until (stream func)
 269   (let ((string "")
 270         (ch))
 271     (setq ch (%peek-char stream))
 272     (while (not (funcall func ch))
 273       (setq string (concat string (string ch)))
 274       (%read-char stream)
 275       (setq ch (%peek-char stream)))
 276     string))
 277
 278 (defun skip-whitespaces-and-comments (stream)
 279   (let (ch)
 280     (skip-whitespaces stream)
 281     (setq ch (%peek-char stream))
 282     (while (and ch (char= ch #\;))
 283       (read-until stream (lambda (x) (char= x #\newline)))
 284       (skip-whitespaces stream)
 285       (setq ch (%peek-char stream)))))
 286
 287 (defun %read-list (stream)
 288   (skip-whitespaces-and-comments stream)
 289   (let ((ch (%peek-char stream)))
 290     (cond
 291       ((char= ch #\))
 292        (%read-char stream)
 293        nil)
 294       ((char= ch #\.)
 295        (%read-char stream)
 296        (skip-whitespaces-and-comments stream)
 297        (prog1 (ls-read stream)
 298          (unless (char= (%read-char stream) #\))
 299            (error "')' was expected."))))
 300       (t
 301        (cons (ls-read stream) (%read-list stream))))))
 302
 303 (defvar *eof* (make-symbol "EOF"))
 304 (defun ls-read (stream)
 305   (skip-whitespaces-and-comments stream)
 306   (let ((ch (%peek-char stream)))
 307     (cond
 308       ((null ch)
 309        *eof*)
 310       ((char= ch #\()
 311        (%read-char stream)
 312        (%read-list stream))
 313       ((char= ch #\')
 314        (%read-char stream)
 315        (list 'quote (ls-read stream)))
 316       ((char= ch #\`)
 317        (%read-char stream)
 318        (list 'backquote (ls-read stream)))
 319       ((char= ch #\")
 320        (%read-char stream)
 321        (prog1 (read-until stream (lambda (ch) (char= ch #\")))
 322          (%read-char stream)))
 323       ((char= ch #\,)
 324        (%read-char stream)
 325        (if (eql (%peek-char stream) #\@)
 326            (progn (%read-char stream) (list 'unquote-splicing (ls-read stream)))
 327            (list 'unquote (ls-read stream))))
 328       ((char= ch #\#)
 329        (%read-char stream)
 330        (ecase (%read-char stream)
 331          (#\'
 332           (list 'function (ls-read stream)))
 333          (#\\
 334           (let ((cname
 335                  (concat (string (%read-char stream))
 336                          (read-until stream #'terminalp))))
 337             (cond
 338               ((string= cname "space") (char-code #\space))
 339               ((string= cname "newline") (char-code #\newline))
 340               (t (char-code (char cname 0))))))
 341          (#\+
 342           (let ((feature (read-until stream #'terminalp)))
 343             (cond
 344               ((string= feature "common-lisp")
 345                (ls-read stream)         ;ignore
 346                (ls-read stream))
 347               ((string= feature "lispstrack")
 348                (ls-read stream))
 349               (t
 350                (error "Unknown reader form.")))))))
 351       (t
 352        (let ((string (read-until stream #'terminalp)))
 353          (if (every #'digit-char-p string)
 354              (parse-integer string)
 355              (intern (string-upcase string))))))))