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