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))
 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))))))
 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 (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   (cond
 421     ((stringp seq)
 422      (if b
 423          (slice seq a b)
 424          (slice seq a)))
 425     (t
 426      (error "Unsupported argument."))))
 427
 428 (defmacro do-sequence (iteration &body body)
 429   (let ((seq (gensym))
 430         (index (gensym)))
 431     `(let ((,seq ,(second iteration)))
 432        (cond
 433          ;; Strings
 434          ((stringp ,seq)
 435           (let ((,index 0))
 436             (dotimes (,index (length ,seq))
 437               (let ((,(first iteration)
 438                      (char ,seq ,index)))
 439                 ,@body))))
 440          ;; Lists
 441          ((listp ,seq)
 442           (dolist (,(first iteration) ,seq)
 443             ,@body))
 444          (t
 445           (error "type-error!"))))))
 446
 447 (defun some (function seq)
 448   (do-sequence (elt seq)
 449     (when (funcall function elt)
 450       (return-from some t))))
 451
 452 (defun every (function seq)
 453   (do-sequence (elt seq)
 454     (unless (funcall function elt)
 455       (return-from every nil)))
 456   t)
 457
 458 (defun position (elt sequence)
 459   (let ((pos 0))
 460     (do-sequence (x seq)
 461       (when (eq elt x)
 462         (return))
 463       (incf pos))
 464     pos))
 465
 466 (defun string (x)
 467   (cond ((stringp x) x)
 468         ((symbolp x) (symbol-name x))
 469         (t (char-to-string x))))
 470
 471 (defun equal (x y)
 472   (cond
 473     ((eql x y) t)
 474     ((consp x)
 475      (and (consp y)
 476           (equal (car x) (car y))
 477           (equal (cdr x) (cdr y))))
 478     ((arrayp x)
 479      (and (arrayp y)
 480           (let ((n (length x)))
 481             (when (= (length y) n)
 482               (dotimes (i n)
 483                 (unless (equal (aref x i) (aref y i))
 484                   (return-from equal nil)))
 485               t))))
 486     (t nil)))
 487
 488 (defun string= (s1 s2)
 489   (equal s1 s2))
 490
 491 (defun fdefinition (x)
 492   (cond
 493     ((functionp x)
 494      x)
 495     ((symbolp x)
 496      (symbol-function x))
 497     (t
 498      (error "Invalid function `~S'." x))))
 499
 500 (defun disassemble (function)
 501   (write-line (lambda-code (fdefinition function)))
 502   nil)
 503
 504 (defun documentation (x type)
 505   "Return the documentation of X. TYPE must be the symbol VARIABLE or FUNCTION."
 506   (ecase type
 507     (function
 508      (let ((func (fdefinition x)))
 509        (oget func "docstring")))
 510     (variable
 511      (unless (symbolp x)
 512        (error "The type of documentation `~S' is not a symbol." type))
 513      (oget x "vardoc"))))
 514
 515 (defmacro multiple-value-bind (variables value-from &body body)
 516   `(multiple-value-call (lambda (&optional ,@variables &rest ,(gensym))
 517                           ,@body)
 518      ,value-from))
 519
 520 (defmacro multiple-value-list (value-from)
 521   `(multiple-value-call #'list ,value-from))
 522
 523
 524 ;;; Generalized references (SETF)
 525
 526 (defvar *setf-expanders* nil)
 527
 528 (defun get-setf-expansion (place)
 529   (if (symbolp place)
 530       (let ((value (gensym)))
 531         (values nil
 532                 nil
 533                 `(,value)
 534                 `(setq ,place ,value)
 535                 place))
 536       (let ((place (!macroexpand-1 place)))
 537         (let* ((access-fn (car place))
 538                (expander (cdr (assoc access-fn *setf-expanders*))))
 539           (when (null expander)
 540             (error "Unknown generalized reference."))
 541           (apply expander (cdr place))))))
 542
 543 (defmacro define-setf-expander (access-fn lambda-list &body body)
 544   (unless (symbolp access-fn)
 545     (error "ACCESS-FN `~S' must be a symbol." access-fn))
 546   `(progn (push (cons ',access-fn (lambda ,lambda-list ,@body))
 547                 *setf-expanders*)
 548           ',access-fn))
 549
 550 (defmacro setf (&rest pairs)
 551   (cond
 552     ((null pairs)
 553      nil)
 554     ((null (cdr pairs))
 555      (error "Odd number of arguments to setf."))
 556     ((null (cddr pairs))
 557      (let ((place (!macroexpand-1 (first pairs)))
 558            (value (second pairs)))
 559        (multiple-value-bind (vars vals store-vars writer-form)
 560            (get-setf-expansion place)
 561          ;; TODO: Optimize the expansion a little bit to avoid let*
 562          ;; or multiple-value-bind when unnecesary.
 563          `(let* ,(mapcar #'list vars vals)
 564             (multiple-value-bind ,store-vars
 565                 ,value
 566               ,writer-form)))))
 567     (t
 568      `(progn
 569         ,@(do ((pairs pairs (cddr pairs))
 570                (result '() (cons `(setf ,(car pairs) ,(cadr pairs)) result)))
 571               ((null pairs)
 572                (reverse result)))))))
 573
 574 ;; Incorrect typecase, but used in NCONC.
 575 (defmacro typecase (x &rest clausules)
 576   (let ((value (gensym)))
 577     `(let ((,value ,x))
 578        (cond
 579          ,@(mapcar (lambda (c)
 580                      (if (eq (car c) t)
 581                          `((t ,@(rest c)))
 582                          `((,(ecase (car c)
 583                                     (integer 'integerp)
 584                                     (cons 'consp)
 585                                     (symbol 'symbolp)
 586                                     (array 'arrayp)
 587                                     (string 'stringp)
 588                                     (atom 'atom)
 589                                     (null 'null))
 590                              ,value)
 591                            ,@(or (rest c)
 592                                  (list nil)))))
 593                    clausules)))))
 594
 595 (defun notany (fn seq)
 596   (not (some fn seq)))
 597
 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 :initial-value ""))
 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)))