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