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