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