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