src/boot.lisp

   1 ;;; boot.lisp --- First forms to be cross compiled
   2
   3 ;; Copyright (C) 2012, 2013 David Vazquez
   4 ;; Copyright (C) 2012 Raimon Grau
   5
   6 ;; JSCL is free software: you can redistribute it and/or
   7 ;; modify it under the terms of the GNU General Public License as
   8 ;; published by the Free Software Foundation, either version 3 of the
   9 ;; License, or (at your option) any later version.
  10 ;;
  11 ;; JSCL is distributed in the hope that it will be useful, but
  12 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  13 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  14 ;; General Public License for more details.
  15 ;;
  16 ;; You should have received a copy of the GNU General Public License
  17 ;; along with JSCL.  If not, see <http://www.gnu.org/licenses/>.
  18
  19 ;;; This code is executed when JSCL compiles this file itself. The
  20 ;;; compiler provides compilation of some special forms, as well as
  21 ;;; funcalls and macroexpansion, but no functions. So, we define the
  22 ;;; Lisp world from scratch. This code has to define enough language
  23 ;;; to the compiler to be able to run.
  24
  25 (/debug "loading boot.lisp!")
  26
  27 (eval-when (:compile-toplevel)
  28   (let ((defmacro-macroexpander
  29          '#'(lambda (form)
  30               (destructuring-bind (name args &body body)
  31                   form
  32                 (let ((whole (gensym)))
  33                   `(eval-when (:compile-toplevel :execute)
  34                      (%compile-defmacro ',name
  35                                         '#'(lambda (,whole)
  36                                              (destructuring-bind ,args ,whole
  37                                                ,@body)))))))))
  38     (%compile-defmacro 'defmacro defmacro-macroexpander)))
  39
  40 (defmacro declaim (&rest decls)
  41   `(eval-when (:compile-toplevel :execute)
  42      ,@(mapcar (lambda (decl) `(!proclaim ',decl)) decls)))
  43
  44 (defmacro defconstant (name value &optional docstring)
  45   `(progn
  46      (declaim (special ,name))
  47      (declaim (constant ,name))
  48      (setq ,name ,value)
  49      ,@(when (stringp docstring) `((oset ,docstring ',name "vardoc")))
  50      ',name))
  51
  52 (defconstant t 't)
  53 (defconstant nil 'nil)
  54 (%js-vset "nil" nil)
  55
  56 (defmacro lambda (args &body body)
  57   `(function (lambda ,args ,@body)))
  58
  59 (defmacro when (condition &body body)
  60   `(if ,condition (progn ,@body) nil))
  61
  62 (defmacro unless (condition &body body)
  63   `(if ,condition nil (progn ,@body)))
  64
  65 (defmacro defvar (name &optional (value nil value-p) docstring)
  66   `(progn
  67      (declaim (special ,name))
  68      ,@(when value-p `((unless (boundp ',name) (setq ,name ,value))))
  69      ,@(when (stringp docstring) `((oset ,docstring ',name "vardoc")))
  70      ',name))
  71
  72 (defmacro defparameter (name value &optional docstring)
  73   `(progn
  74      (setq ,name ,value)
  75      ,@(when (stringp docstring) `((oset ,docstring ',name "vardoc")))
  76      ',name))
  77
  78 (defmacro defun (name args &rest body)
  79   `(progn
  80      (fset ',name #'(named-lambda ,name ,args ,@body))
  81      ',name))
  82
  83 (defmacro return (&optional value)
  84   `(return-from nil ,value))
  85
  86 (defmacro while (condition &body body)
  87   `(block nil (%while ,condition ,@body)))
  88
  89 (defvar *gensym-counter* 0)
  90 (defun gensym (&optional (prefix "G"))
  91   (setq *gensym-counter* (+ *gensym-counter* 1))
  92   (make-symbol (concat prefix (integer-to-string *gensym-counter*))))
  93
  94 (defun boundp (x)
  95   (boundp x))
  96
  97 (defun fboundp (x)
  98   (fboundp x))
  99
 100 (defun eq (x y) (eq x y))
 101 (defun eql (x y) (eq x y))
 102
 103 (defun not (x) (if x nil t))
 104
 105 ;; Basic macros
 106
 107 (defmacro dolist ((var list &optional result) &body body)
 108   (let ((g!list (gensym)))
 109     (unless (symbolp var) (error "`~S' is not a symbol." var))
 110     `(block nil
 111        (let ((,g!list ,list)
 112              (,var nil))
 113          (%while ,g!list
 114                  (setq ,var (car ,g!list))
 115                  (tagbody ,@body)
 116                  (setq ,g!list (cdr ,g!list)))
 117          ,result))))
 118
 119 (defmacro dotimes ((var count &optional result) &body body)
 120   (let ((g!count (gensym)))
 121     (unless (symbolp var) (error "`~S' is not a symbol." var))
 122     `(block nil
 123        (let ((,var 0)
 124              (,g!count ,count))
 125          (%while (< ,var ,g!count)
 126                  (tagbody ,@body)
 127                  (incf ,var))
 128          ,result))))
 129
 130 (defmacro cond (&rest clausules)
 131   (unless (null clausules)
 132     (destructuring-bind (condition &body body)
 133         (first clausules)
 134       (cond
 135         ((eq condition t)
 136          `(progn ,@body))
 137         ((null body)
 138          (let ((test-symbol (gensym)))
 139            `(let ((,test-symbol ,condition))
 140               (if ,test-symbol
 141                   ,test-symbol
 142                   (cond ,@(rest clausules))))))
 143         (t
 144          `(if ,condition
 145               (progn ,@body)
 146               (cond ,@(rest clausules))))))))
 147
 148 (defmacro case (form &rest clausules)
 149   (let ((!form (gensym)))
 150     `(let ((,!form ,form))
 151        (cond
 152          ,@(mapcar (lambda (clausule)
 153                      (destructuring-bind (keys &body body)
 154                          clausule
 155                        (if (or (eq keys 't) (eq keys 'otherwise))
 156                            `(t nil ,@body)
 157                            (let ((keys (if (listp keys) keys (list keys))))
 158                              `((or ,@(mapcar (lambda (key) `(eql ,!form ',key)) keys))
 159                                nil ,@body)))))
 160                    clausules)))))
 161
 162 (defmacro ecase (form &rest clausules)
 163   (let ((g!form (gensym)))
 164     `(let ((,g!form ,form))
 165        (case ,g!form
 166          ,@(append
 167             clausules
 168             `((t
 169                (error "ECASE expression failed for the object `~S'." ,g!form))))))))
 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 (defmacro or (&rest forms)
 183   (cond
 184     ((null forms)
 185      nil)
 186     ((null (cdr forms))
 187      (car forms))
 188     (t
 189      (let ((g (gensym)))
 190        `(let ((,g ,(car forms)))
 191           (if ,g ,g (or ,@(cdr forms))))))))
 192
 193 (defmacro prog1 (form &body body)
 194   (let ((value (gensym)))
 195     `(let ((,value ,form))
 196        ,@body
 197        ,value)))
 198
 199 (defmacro prog2 (form1 result &body body)
 200   `(prog1 (progn ,form1 ,result) ,@body))
 201
 202 (defmacro prog (inits &rest body )
 203   (multiple-value-bind (forms decls docstring) (parse-body body)
 204     `(block nil
 205        (let ,inits
 206          ,@decls
 207          (tagbody ,@forms)))))
 208
 209 (defmacro psetq (&rest pairs)
 210   (let (;; For each pair, we store here a list of the form
 211         ;; (VARIABLE GENSYM VALUE).
 212         (assignments '()))
 213     (while t
 214       (cond
 215         ((null pairs) (return))
 216         ((null (cdr pairs))
 217          (error "Odd paris in PSETQ"))
 218         (t
 219          (let ((variable (car pairs))
 220                (value (cadr pairs)))
 221            (push `(,variable ,(gensym) ,value)  assignments)
 222            (setq pairs (cddr pairs))))))
 223     (setq assignments (reverse assignments))
 224     ;;
 225     `(let ,(mapcar #'cdr assignments)
 226        (setq ,@(!reduce #'append (mapcar #'butlast assignments) nil)))))
 227
 228 (defmacro do (varlist endlist &body body)
 229   `(block nil
 230      (let ,(mapcar (lambda (x) (if (symbolp x)
 231                                    (list x nil)
 232                                  (list (first x) (second x)))) varlist)
 233        (while t
 234          (when ,(car endlist)
 235            (return (progn ,@(cdr endlist))))
 236          (tagbody ,@body)
 237          (psetq
 238           ,@(apply #'append
 239                    (mapcar (lambda (v)
 240                              (and (listp v)
 241                                   (consp (cddr v))
 242                                   (list (first v) (third v))))
 243                            varlist)))))))
 244
 245 (defmacro do* (varlist endlist &body body)
 246   `(block nil
 247      (let* ,(mapcar (lambda (x1) (if (symbolp x1)
 248                                      (list x1 nil)
 249                                    (list (first x1) (second x1)))) varlist)
 250        (while t
 251          (when ,(car endlist)
 252            (return (progn ,@(cdr endlist))))
 253          (tagbody ,@body)
 254          (setq
 255           ,@(apply #'append
 256                    (mapcar (lambda (v)
 257                              (and (listp v)
 258                                   (consp (cddr v))
 259                                   (list (first v) (third v))))
 260                            varlist)))))))
 261
 262 (defmacro with-collect (&body body)
 263   (let ((head (gensym))
 264         (tail (gensym)))
 265     `(let* ((,head (cons 'sentinel nil))
 266             (,tail ,head))
 267        (flet ((collect (x)
 268                 (rplacd ,tail (cons x nil))
 269                 (setq ,tail (cdr ,tail))
 270                 x))
 271          ,@body)
 272        (cdr ,head))))
 273
 274
 275 (defmacro loop (&body body)
 276   `(while t ,@body))
 277
 278 (defun identity (x) x)
 279
 280 (defun complement (x)
 281   (lambda (&rest args)
 282     (not (apply x args))))
 283
 284 (defun constantly (x)
 285   (lambda (&rest args)
 286     x))
 287
 288 (defun code-char (x)
 289   (code-char x))
 290
 291 (defun char-code (x)
 292   (char-code x))
 293
 294 (defun char= (x y)
 295   (eql x y))
 296
 297 (defun char< (x y)
 298   (< (char-code x) (char-code y)))
 299
 300 (defun atom (x)
 301   (not (consp x)))
 302
 303 (defun alpha-char-p (x)
 304   (or (<= (char-code #\a) (char-code x) (char-code #\z))
 305       (<= (char-code #\A) (char-code x) (char-code #\Z))))
 306
 307 (defun digit-char-p (x)
 308   (if (and (<= (char-code #\0) (char-code x) (char-code #\9)))
 309       (- (char-code x) (char-code #\0))
 310       nil))
 311
 312 (defun digit-char (weight)
 313   (and (<= 0 weight 9)
 314        (char "0123456789" weight)))
 315
 316 (defun equal (x y)
 317   (cond
 318     ((eql x y) t)
 319     ((consp x)
 320      (and (consp y)
 321           (equal (car x) (car y))
 322           (equal (cdr x) (cdr y))))
 323     ((stringp x)
 324      (and (stringp y) (string= x y)))
 325     (t nil)))
 326
 327 (defun fdefinition (x)
 328   (cond
 329     ((functionp x)
 330      x)
 331     ((symbolp x)
 332      (symbol-function x))
 333     (t
 334      (error "Invalid function `~S'." x))))
 335
 336 (defun disassemble (function)
 337   (write-line (lambda-code (fdefinition function)))
 338   nil)
 339
 340 (defmacro multiple-value-bind (variables value-from &body body)
 341   `(multiple-value-call (lambda (&optional ,@variables &rest ,(gensym))
 342                           ,@body)
 343      ,value-from))
 344
 345 (defmacro multiple-value-list (value-from)
 346   `(multiple-value-call #'list ,value-from))
 347
 348
 349 ;;; Generalized references (SETF)
 350
 351 (eval-when(:compile-toplevel :load-toplevel :execute)
 352   (defvar *setf-expanders* nil)
 353   (defun !get-setf-expansion (place)
 354     (if (symbolp place)
 355         (let ((value (gensym)))
 356           (values nil
 357                   nil
 358                   `(,value)
 359                   `(setq ,place ,value)
 360                   place))
 361         (let ((place (!macroexpand-1 place)))
 362           (let* ((access-fn (car place))
 363                  (expander (cdr (assoc access-fn *setf-expanders*))))
 364             (when (null expander)
 365               (error "Unknown generalized reference."))
 366             (apply expander (cdr place)))))))
 367 (fset 'get-setf-expansion (fdefinition '!get-setf-expansion))
 368
 369 (defmacro define-setf-expander (access-fn lambda-list &body body)
 370   (unless (symbolp access-fn)
 371     (error "ACCESS-FN `~S' must be a symbol." access-fn))
 372   `(progn (push (cons ',access-fn (lambda ,lambda-list ,@body))
 373                 *setf-expanders*)
 374           ',access-fn))
 375
 376 (defmacro setf (&rest pairs)
 377   (cond
 378     ((null pairs)
 379      nil)
 380     ((null (cdr pairs))
 381      (error "Odd number of arguments to setf."))
 382     ((null (cddr pairs))
 383      (let ((place (!macroexpand-1 (first pairs)))
 384            (value (second pairs)))
 385        (multiple-value-bind (vars vals store-vars writer-form reader-form)
 386            (!get-setf-expansion place)
 387          ;; TODO: Optimize the expansion a little bit to avoid let*
 388          ;; or multiple-value-bind when unnecesary.
 389          `(let* ,(mapcar #'list vars vals)
 390             (multiple-value-bind ,store-vars
 391                 ,value
 392               ,writer-form
 393               ,reader-form)))))
 394     (t
 395      `(progn
 396         ,@(do ((pairs pairs (cddr pairs))
 397                (result '() (cons `(setf ,(car pairs) ,(cadr pairs)) result)))
 398               ((null pairs)
 399                (reverse result)))))))
 400
 401 (defmacro incf (place &optional (delta 1))
 402   (multiple-value-bind (dummies vals newval setter getter)
 403       (!get-setf-expansion place)
 404     (let ((d (gensym)))
 405       `(let* (,@(mapcar #'list dummies vals)
 406               (,d ,delta)
 407                 (,(car newval) (+ ,getter ,d))
 408                 ,@(cdr newval))
 409          ,setter))))
 410
 411 (defmacro decf (place &optional (delta 1))
 412   (multiple-value-bind (dummies vals newval setter getter)
 413       (!get-setf-expansion place)
 414     (let ((d (gensym)))
 415       `(let* (,@(mapcar #'list dummies vals)
 416               (,d ,delta)
 417               (,(car newval) (- ,getter ,d))
 418               ,@(cdr newval))
 419          ,setter))))
 420
 421 (defmacro push (x place)
 422   (multiple-value-bind (dummies vals newval setter getter)
 423       (!get-setf-expansion place)
 424     (let ((g (gensym)))
 425       `(let* ((,g ,x)
 426               ,@(mapcar #'list dummies vals)
 427               (,(car newval) (cons ,g ,getter))
 428               ,@(cdr newval))
 429          ,setter))))
 430
 431 (defmacro pop (place)
 432   (multiple-value-bind (dummies vals newval setter getter)
 433     (!get-setf-expansion place)
 434     (let ((head (gensym)))
 435       `(let* (,@(mapcar #'list dummies vals)
 436               (,head ,getter)
 437               (,(car newval) (cdr ,head))
 438               ,@(cdr newval))
 439          ,setter
 440          (car ,head)))))
 441
 442 (defmacro pushnew (x place &rest keys &key key test test-not)
 443   (declare (ignore key test test-not))
 444   (multiple-value-bind (dummies vals newval setter getter)
 445       (!get-setf-expansion place)
 446     (let ((g (gensym))
 447           (v (gensym)))
 448       `(let* ((,g ,x)
 449               ,@(mapcar #'list dummies vals)
 450               ,@(cdr newval)
 451               (,v ,getter))
 452          (if (member ,g ,v ,@keys)
 453              ,v
 454              (let ((,(car newval) (cons ,g ,getter)))
 455                ,setter))))))
 456
 457
 458
 459 ;; Incorrect typecase, but used in NCONC.
 460 (defmacro typecase (x &rest clausules)
 461   (let ((value (gensym)))
 462     `(let ((,value ,x))
 463        (cond
 464          ,@(mapcar (lambda (c)
 465                      (if (find (car c) '(t otherwise))
 466                          `(t ,@(rest c))
 467                          `((,(ecase (car c)
 468                                     (integer 'integerp)
 469                                     (cons 'consp)
 470                                     (list 'listp)
 471                                     (vector 'vectorp)
 472                                     (character 'characterp)
 473                                     (sequence 'sequencep)
 474                                     (symbol 'symbolp)
 475                                     (function 'functionp)
 476                                     (float 'floatp)
 477                                     (array 'arrayp)
 478                                     (string 'stringp)
 479                                     (atom 'atom)
 480                                     (null 'null)
 481                                     (package 'packagep))
 482                              ,value)
 483                            ,@(or (rest c)
 484                                  (list nil)))))
 485                    clausules)))))
 486
 487 (defmacro etypecase (x &rest clausules)
 488   (let ((g!x (gensym)))
 489     `(let ((,g!x ,x))
 490        (typecase ,g!x
 491          ,@clausules
 492          (t (error "~S fell through etypecase expression." ,g!x))))))
 493
 494 (defun notany (fn seq)
 495   (not (some fn seq)))
 496
 497 (defconstant internal-time-units-per-second 1000)
 498
 499 (defun get-internal-real-time ()
 500   (get-internal-real-time))
 501
 502 (defun get-unix-time ()
 503   (truncate (/ (get-internal-real-time) 1000)))
 504
 505 (defun get-universal-time ()
 506   (+ (get-unix-time) 2208988800))
 507
 508 (defun values-list (list)
 509   (values-array (list-to-vector list)))
 510
 511 (defun values (&rest args)
 512   (values-list args))
 513
 514 (defun error (fmt &rest args)
 515   (%throw (apply #'format nil fmt args)))
 516
 517 (defmacro nth-value (n form)
 518   `(multiple-value-call (lambda (&rest values)
 519                           (nth ,n values))
 520      ,form))