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