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