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
 108 (defmacro case (form &rest clausules)
 109   (let ((!form (make-symbol "FORM")))
 110     `(let ((,!form ,form))
 111        (cond
 112          ,@(mapcar (lambda (clausule)
 113                      (if (eq (car clausule) t)
 114                          clausule
 115                          `((eql ,!form ,(car clausule))
 116                            ,@(cdr clausule))))
 117                    clausules)))))
 118
 119 (defmacro ecase (form &rest clausules)
 120   `(case ,form
 121      ,@(append
 122         clausules
 123         `((t
 124            (error "ECASE expression failed."))))))
 125
 126 (defun !reduce (func list initial)
 127   (if (null list)
 128       initial
 129       (!reduce func
 130                (cdr list)
 131                (funcall func initial (car list)))))
 132
 133
 134 (defun code-char (x) x)
 135 (defun char-code (x) x)
 136 (defvar *newline* (string (code-char 10)))
 137
 138 (defun concat (&rest strs)
 139   (!reduce (lambda (s1 s2) (concat-two s1 s2))
 140            strs
 141            ""))
 142
 143 ;;; Concatenate a list of strings, with a separator
 144 (defun join (list separator)
 145   (cond
 146     ((null list)
 147      "")
 148     ((null (cdr list))
 149      (car list))
 150     (t
 151      (concat (car list)
 152              separator
 153              (join (cdr list) separator)))))
 154
 155 (defun join-trailing (list separator)
 156   (if (null list)
 157       ""
 158       (concat (car list) separator (join-trailing (cdr list) separator))))
 159
 160 (defun integer-to-string (x)
 161   (if (zerop x)
 162       "0"
 163       (let ((digits nil))
 164         (while (not (zerop x 0))
 165           (push (mod x 10) digits)
 166           (setq x (truncate x 10)))
 167         (join (mapcar (lambda (d) (string (char "0123456789" d)))
 168                       digits)
 169               ""))))
 170
 171 (defmacro and (&rest forms)
 172   (cond
 173     ((null forms)
 174      t)
 175     ((null (cdr forms))
 176      (car forms))
 177     (t
 178      `(if ,(car forms)
 179           (and ,@(cdr forms))
 180           nil))))
 181
 182
 183 (defmacro or (&rest forms)
 184   (cond
 185     ((null forms)
 186      nil)
 187     ((null (cdr forms))
 188      (car forms))
 189     (t
 190      `(if ,(car forms)
 191           t
 192           (or ,@(cdr forms))))))
 193
 194
 195 (defmacro prog1 (form &rest body)
 196   (let ((value (make-symbol "VALUE")))
 197     `(let ((,value ,form))
 198        ,@body
 199        ,value)))
 200
 201
 202 (defun char= (x y) (= x y))
 203
 204
 205 ;;;; Reader
 206
 207 ;;; It is a basic Lisp reader. It does not use advanced stuff
 208 ;;; intentionally, because we want to use it to bootstrap a simple
 209 ;;; Lisp. The main entry point is the function `ls-read', which
 210 ;;; accepts a strings as argument and return the Lisp expression.
 211 (defun make-string-stream (string)
 212   (cons string 0))
 213
 214 (defun %peek-char (stream)
 215   (and (< (cdr stream) (length (car stream)))
 216        (char (car stream) (cdr stream))))
 217
 218 (defun %read-char (stream)
 219   (and (< (cdr stream) (length (car stream)))
 220        (prog1 (char (car stream) (cdr stream))
 221          (setcdr stream (1+ (cdr stream))))))
 222
 223 (defun whitespacep (ch)
 224   (or (char= ch #\space) (char= ch #\newline) (char= ch #\tab)))
 225
 226 (defun skip-whitespaces (stream)
 227   (let (ch)
 228     (setq ch (%peek-char stream))
 229     (while (and ch (whitespacep ch))
 230       (%read-char stream)
 231       (setq ch (%peek-char stream)))))
 232
 233 (defun terminalp (ch)
 234   (or (null ch) (whitespacep ch) (char= #\) ch) (char= #\( ch)))
 235
 236
 237 (defun read-until (stream func)
 238   (let ((string "")
 239         (ch))
 240     (setq ch (%peek-char stream))
 241     (while (not (funcall func ch))
 242       (setq string (concat string (string ch)))
 243       (%read-char stream)
 244       (setq ch (%peek-char stream)))
 245     string))
 246
 247 (defun skip-whitespaces-and-comments (stream)
 248   (let (ch)
 249     (skip-whitespaces stream)
 250     (setq ch (%peek-char stream))
 251     (while (and ch (char= ch #\;))
 252       (read-until stream (lambda (x) (char= x #\newline)))
 253       (skip-whitespaces stream)
 254       (setq ch (%peek-char stream)))))
 255
 256 (defun %read-list (stream)
 257   (skip-whitespaces-and-comments stream)
 258   (let ((ch (%peek-char stream)))
 259     (cond
 260       ((char= ch #\))
 261        (%read-char stream)
 262        nil)
 263       ((char= ch #\.)
 264        (%read-char stream)
 265        (skip-whitespaces-and-comments stream)
 266        (prog1 (ls-read stream)
 267          (unless (char= (%read-char stream) #\))
 268            (error "')' was expected."))))
 269       (t
 270        (cons (ls-read stream) (%read-list stream))))))
 271
 272 (defvar *eof* (make-symbol "EOF"))
 273 (defun ls-read (stream)
 274   (skip-whitespaces-and-comments stream)
 275   (let ((ch (%peek-char stream)))
 276     (cond
 277       ((null ch)
 278        *eof*)
 279       ((char= ch #\()
 280        (%read-char stream)
 281        (%read-list stream))
 282       ((char= ch #\')
 283        (%read-char stream)
 284        (list 'quote (ls-read stream)))
 285       ((char= ch #\`)
 286        (%read-char stream)
 287        (list 'backquote (ls-read stream)))
 288       ((char= ch #\")
 289        (%read-char stream)
 290        (prog1 (read-until stream (lambda (ch) (char= ch #\")))
 291          (%read-char stream)))
 292       ((char= ch #\,)
 293        (%read-char stream)
 294        (if (eql (%peek-char stream) #\@)
 295            (progn (%read-char stream) (list 'unquote-splicing (ls-read stream)))
 296            (list 'unquote (ls-read stream))))
 297       ((char= ch #\#)
 298        (%read-char stream)
 299        (ecase (%read-char stream)
 300          (#\'
 301           (list 'function (ls-read stream)))
 302          (#\\
 303           (let ((cname
 304                  (concat (string (%read-char stream))
 305                          (read-until stream #'terminalp))))
 306             (cond
 307               ((string= cname "space") (char-code #\space))
 308               ((string= cname "newline") (char-code #\newline))
 309               (t (char-code (char cname 0))))))
 310          (#\+
 311           (let ((feature (read-until stream #'terminalp)))
 312             (cond
 313               ((string= feature "common-lisp")
 314                (ls-read stream)         ;ignore
 315                (ls-read stream))
 316               ((string= feature "lispstrack")
 317                (ls-read stream))
 318               (t
 319                (error "Unknown reader form.")))))))
 320       (t
 321        (let ((string (read-until stream #'terminalp)))
 322          (if (every #'digit-char-p string)
 323              (parse-integer string)
 324              (intern (string-upcase string))))))))