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 (defun funcall (function &rest args)
 106   (apply function args))
 107
 108 (defun apply (function arg &rest args)
 109   (apply function (apply #'list* arg args)))
 110
 111 ;; Basic macros
 112
 113 (defmacro dolist ((var list &optional result) &body body)
 114   (let ((g!list (gensym)))
 115     (unless (symbolp var) (error "`~S' is not a symbol." var))
 116     `(block nil
 117        (let ((,g!list ,list)
 118              (,var nil))
 119          (%while ,g!list
 120                  (setq ,var (car ,g!list))
 121                  (tagbody ,@body)
 122                  (setq ,g!list (cdr ,g!list)))
 123          ,result))))
 124
 125 (defmacro dotimes ((var count &optional result) &body body)
 126   (let ((g!count (gensym)))
 127     (unless (symbolp var) (error "`~S' is not a symbol." var))
 128     `(block nil
 129        (let ((,var 0)
 130              (,g!count ,count))
 131          (%while (< ,var ,g!count)
 132                  (tagbody ,@body)
 133                  (incf ,var))
 134          ,result))))
 135
 136 (defmacro cond (&rest clausules)
 137   (unless (null clausules)
 138     (destructuring-bind (condition &body body)
 139         (first clausules)
 140       (cond
 141         ((eq condition t)
 142          `(progn ,@body))
 143         ((null body)
 144          (let ((test-symbol (gensym)))
 145            `(let ((,test-symbol ,condition))
 146               (if ,test-symbol
 147                   ,test-symbol
 148                   (cond ,@(rest clausules))))))
 149         (t
 150          `(if ,condition
 151               (progn ,@body)
 152               (cond ,@(rest clausules))))))))
 153
 154 (defmacro case (form &rest clausules)
 155   (let ((!form (gensym)))
 156     `(let ((,!form ,form))
 157        (cond
 158          ,@(mapcar (lambda (clausule)
 159                      (destructuring-bind (keys &body body)
 160                          clausule
 161                        (if (or (eq keys 't) (eq keys 'otherwise))
 162                            `(t nil ,@body)
 163                            (let ((keys (if (listp keys) keys (list keys))))
 164                              `((or ,@(mapcar (lambda (key) `(eql ,!form ',key)) keys))
 165                                nil ,@body)))))
 166                    clausules)))))
 167
 168 (defmacro ecase (form &rest clausules)
 169   (let ((g!form (gensym)))
 170     `(let ((,g!form ,form))
 171        (case ,g!form
 172          ,@(append
 173             clausules
 174             `((t
 175                (error "ECASE expression failed for the object `~S'." ,g!form))))))))
 176
 177 (defmacro and (&rest forms)
 178   (cond
 179     ((null forms)
 180      t)
 181     ((null (cdr forms))
 182      (car forms))
 183     (t
 184      `(if ,(car forms)
 185           (and ,@(cdr forms))
 186           nil))))
 187
 188 (defmacro or (&rest forms)
 189   (cond
 190     ((null forms)
 191      nil)
 192     ((null (cdr forms))
 193      (car forms))
 194     (t
 195      (let ((g (gensym)))
 196        `(let ((,g ,(car forms)))
 197           (if ,g ,g (or ,@(cdr forms))))))))
 198
 199 (defmacro prog1 (form &body body)
 200   (let ((value (gensym)))
 201     `(let ((,value ,form))
 202        ,@body
 203        ,value)))
 204
 205 (defmacro prog2 (form1 result &body body)
 206   `(prog1 (progn ,form1 ,result) ,@body))
 207
 208 (defmacro prog (inits &rest body )
 209   (multiple-value-bind (forms decls docstring) (parse-body body)
 210     `(block nil
 211        (let ,inits
 212          ,@decls
 213          (tagbody ,@forms)))))
 214
 215 (defmacro psetq (&rest pairs)
 216   (let (;; For each pair, we store here a list of the form
 217         ;; (VARIABLE GENSYM VALUE).
 218         (assignments '()))
 219     (while t
 220       (cond
 221         ((null pairs) (return))
 222         ((null (cdr pairs))
 223          (error "Odd paris in PSETQ"))
 224         (t
 225          (let ((variable (car pairs))
 226                (value (cadr pairs)))
 227            (push `(,variable ,(gensym) ,value)  assignments)
 228            (setq pairs (cddr pairs))))))
 229     (setq assignments (reverse assignments))
 230     ;;
 231     `(let ,(mapcar #'cdr assignments)
 232        (setq ,@(!reduce #'append (mapcar #'butlast assignments) nil)))))
 233
 234 (defmacro do (varlist endlist &body body)
 235   `(block nil
 236      (let ,(mapcar (lambda (x) (if (symbolp x)
 237                                    (list x nil)
 238                                  (list (first x) (second x)))) varlist)
 239        (while t
 240          (when ,(car endlist)
 241            (return (progn ,@(cdr endlist))))
 242          (tagbody ,@body)
 243          (psetq
 244           ,@(apply #'append
 245                    (mapcar (lambda (v)
 246                              (and (listp v)
 247                                   (consp (cddr v))
 248                                   (list (first v) (third v))))
 249                            varlist)))))))
 250
 251 (defmacro do* (varlist endlist &body body)
 252   `(block nil
 253      (let* ,(mapcar (lambda (x1) (if (symbolp x1)
 254                                      (list x1 nil)
 255                                    (list (first x1) (second x1)))) varlist)
 256        (while t
 257          (when ,(car endlist)
 258            (return (progn ,@(cdr endlist))))
 259          (tagbody ,@body)
 260          (setq
 261           ,@(apply #'append
 262                    (mapcar (lambda (v)
 263                              (and (listp v)
 264                                   (consp (cddr v))
 265                                   (list (first v) (third v))))
 266                            varlist)))))))
 267
 268 (defmacro with-collect (&body body)
 269   (let ((head (gensym))
 270         (tail (gensym)))
 271     `(let* ((,head (cons 'sentinel nil))
 272             (,tail ,head))
 273        (flet ((collect (x)
 274                 (rplacd ,tail (cons x nil))
 275                 (setq ,tail (cdr ,tail))
 276                 x))
 277          ,@body)
 278        (cdr ,head))))
 279
 280
 281 (defmacro loop (&body body)
 282   `(while t ,@body))
 283
 284 (defun identity (x) x)
 285
 286 (defun complement (x)
 287   (lambda (&rest args)
 288     (not (apply x args))))
 289
 290 (defun constantly (x)
 291   (lambda (&rest args)
 292     x))
 293
 294 (defun code-char (x)
 295   (code-char x))
 296
 297 (defun char-code (x)
 298   (char-code x))
 299
 300 (defun char= (x y)
 301   (eql x y))
 302
 303 (defun char< (x y)
 304   (< (char-code x) (char-code y)))
 305
 306 (defun atom (x)
 307   (not (consp x)))
 308
 309 (defun alpha-char-p (x)
 310   (or (<= (char-code #\a) (char-code x) (char-code #\z))
 311       (<= (char-code #\A) (char-code x) (char-code #\Z))))
 312
 313 (defun digit-char-p (x)
 314   (if (and (<= (char-code #\0) (char-code x) (char-code #\9)))
 315       (- (char-code x) (char-code #\0))
 316       nil))
 317
 318 (defun digit-char (weight)
 319   (and (<= 0 weight 9)
 320        (char "0123456789" weight)))
 321
 322 (defun equal (x y)
 323   (cond
 324     ((eql x y) t)
 325     ((consp x)
 326      (and (consp y)
 327           (equal (car x) (car y))
 328           (equal (cdr x) (cdr y))))
 329     ((stringp x)
 330      (and (stringp y) (string= x y)))
 331     (t nil)))
 332
 333 (defun fdefinition (x)
 334   (cond
 335     ((functionp x)
 336      x)
 337     ((symbolp x)
 338      (symbol-function x))
 339     (t
 340      (error "Invalid function `~S'." x))))
 341
 342 (defun disassemble (function)
 343   (write-line (lambda-code (fdefinition function)))
 344   nil)
 345
 346 (defmacro multiple-value-bind (variables value-from &body body)
 347   `(multiple-value-call (lambda (&optional ,@variables &rest ,(gensym))
 348                           ,@body)
 349      ,value-from))
 350
 351 (defmacro multiple-value-list (value-from)
 352   `(multiple-value-call #'list ,value-from))
 353
 354
 355 ;;; Generalized references (SETF)
 356
 357 (eval-when(:compile-toplevel :load-toplevel :execute)
 358   (defvar *setf-expanders* nil)
 359   (defun !get-setf-expansion (place)
 360     (if (symbolp place)
 361         (let ((value (gensym)))
 362           (values nil
 363                   nil
 364                   `(,value)
 365                   `(setq ,place ,value)
 366                   place))
 367         (let ((place (!macroexpand-1 place)))
 368           (let* ((access-fn (car place))
 369                  (expander (cdr (assoc access-fn *setf-expanders*))))
 370             (when (null expander)
 371               (error "Unknown generalized reference."))
 372             (apply expander (cdr place)))))))
 373 (fset 'get-setf-expansion (fdefinition '!get-setf-expansion))
 374
 375 (defmacro define-setf-expander (access-fn lambda-list &body body)
 376   (unless (symbolp access-fn)
 377     (error "ACCESS-FN `~S' must be a symbol." access-fn))
 378   `(eval-when (:compile-toplevel :load-toplevel :execute)
 379      (push (cons ',access-fn (lambda ,lambda-list ,@body))
 380            *setf-expanders*)
 381      ',access-fn))
 382
 383 (defmacro setf (&rest pairs)
 384   (cond
 385     ((null pairs)
 386      nil)
 387     ((null (cdr pairs))
 388      (error "Odd number of arguments to setf."))
 389     ((null (cddr pairs))
 390      (let ((place (!macroexpand-1 (first pairs)))
 391            (value (second pairs)))
 392        (multiple-value-bind (vars vals store-vars writer-form reader-form)
 393            (!get-setf-expansion place)
 394          (declare (ignorable reader-form))
 395          ;; TODO: Optimize the expansion a little bit to avoid let*
 396          ;; or multiple-value-bind when unnecesary.
 397          `(let* ,(mapcar #'list vars vals)
 398             (multiple-value-bind ,store-vars
 399                 ,value
 400               ,writer-form)))))
 401     (t
 402      `(progn
 403         ,@(do ((pairs pairs (cddr pairs))
 404                (result '() (cons `(setf ,(car pairs) ,(cadr pairs)) result)))
 405               ((null pairs)
 406                (reverse result)))))))
 407
 408 (defmacro incf (place &optional (delta 1))
 409   (multiple-value-bind (dummies vals newval setter getter)
 410       (!get-setf-expansion place)
 411     (let ((d (gensym)))
 412       `(let* (,@(mapcar #'list dummies vals)
 413               (,d ,delta)
 414                 (,(car newval) (+ ,getter ,d))
 415                 ,@(cdr newval))
 416          ,setter))))
 417
 418 (defmacro decf (place &optional (delta 1))
 419   (multiple-value-bind (dummies vals newval setter getter)
 420       (!get-setf-expansion place)
 421     (let ((d (gensym)))
 422       `(let* (,@(mapcar #'list dummies vals)
 423               (,d ,delta)
 424               (,(car newval) (- ,getter ,d))
 425               ,@(cdr newval))
 426          ,setter))))
 427
 428 (defmacro push (x place)
 429   (multiple-value-bind (dummies vals newval setter getter)
 430       (!get-setf-expansion place)
 431     (let ((g (gensym)))
 432       `(let* ((,g ,x)
 433               ,@(mapcar #'list dummies vals)
 434               (,(car newval) (cons ,g ,getter))
 435               ,@(cdr newval))
 436          ,setter))))
 437
 438 (defmacro pop (place)
 439   (multiple-value-bind (dummies vals newval setter getter)
 440     (!get-setf-expansion place)
 441     (let ((head (gensym)))
 442       `(let* (,@(mapcar #'list dummies vals)
 443               (,head ,getter)
 444               (,(car newval) (cdr ,head))
 445               ,@(cdr newval))
 446          ,setter
 447          (car ,head)))))
 448
 449 (defmacro pushnew (x place &rest keys &key key test test-not)
 450   (declare (ignore key test test-not))
 451   (multiple-value-bind (dummies vals newval setter getter)
 452       (!get-setf-expansion place)
 453     (let ((g (gensym))
 454           (v (gensym)))
 455       `(let* ((,g ,x)
 456               ,@(mapcar #'list dummies vals)
 457               ,@(cdr newval)
 458               (,v ,getter))
 459          (if (member ,g ,v ,@keys)
 460              ,v
 461              (let ((,(car newval) (cons ,g ,getter)))
 462                ,setter))))))
 463
 464
 465
 466 ;; Incorrect typecase, but used in NCONC.
 467 (defmacro typecase (x &rest clausules)
 468   (let ((value (gensym)))
 469     `(let ((,value ,x))
 470        (cond
 471          ,@(mapcar (lambda (c)
 472                      (if (find (car c) '(t otherwise))
 473                          `(t ,@(rest c))
 474                          `((,(ecase (car c)
 475                                     (integer 'integerp)
 476                                     (cons 'consp)
 477                                     (list 'listp)
 478                                     (vector 'vectorp)
 479                                     (character 'characterp)
 480                                     (sequence 'sequencep)
 481                                     (symbol 'symbolp)
 482                                     (function 'functionp)
 483                                     (float 'floatp)
 484                                     (array 'arrayp)
 485                                     (string 'stringp)
 486                                     (atom 'atom)
 487                                     (null 'null)
 488                                     (package 'packagep))
 489                              ,value)
 490                            ,@(or (rest c)
 491                                  (list nil)))))
 492                    clausules)))))
 493
 494 (defmacro etypecase (x &rest clausules)
 495   (let ((g!x (gensym)))
 496     `(let ((,g!x ,x))
 497        (typecase ,g!x
 498          ,@clausules
 499          (t (error "~S fell through etypecase expression." ,g!x))))))
 500
 501 (defun notany (fn seq)
 502   (not (some fn seq)))
 503
 504 (defconstant internal-time-units-per-second 1000)
 505
 506 (defun get-internal-real-time ()
 507   (get-internal-real-time))
 508
 509 (defun get-unix-time ()
 510   (truncate (/ (get-internal-real-time) 1000)))
 511
 512 (defun get-universal-time ()
 513   (+ (get-unix-time) 2208988800))
 514
 515 (defun values-list (list)
 516   (values-array (list-to-vector list)))
 517
 518 (defun values (&rest args)
 519   (values-list args))
 520
 521 (defun error (fmt &rest args)
 522   (%throw (apply #'format nil fmt args)))
 523
 524 (defmacro nth-value (n form)
 525   `(multiple-value-call (lambda (&rest values)
 526                           (nth ,n values))
 527      ,form))