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