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 remove (x list)
 378   (cond
 379     ((null list)
 380      nil)
 381     ((eql x (car list))
 382      (remove x (cdr list)))
 383     (t
 384      (cons (car list) (remove x (cdr list))))))
 385
 386 (defun remove-if (func list)
 387   (cond
 388     ((null list)
 389      nil)
 390     ((funcall func (car list))
 391      (remove-if func (cdr list)))
 392     (t
 393      ;;
 394      (cons (car list) (remove-if func (cdr list))))))
 395
 396 (defun remove-if-not (func list)
 397   (cond
 398     ((null list)
 399      nil)
 400     ((funcall func (car list))
 401      (cons (car list) (remove-if-not func (cdr list))))
 402     (t
 403      (remove-if-not func (cdr list)))))
 404
 405 (defun alpha-char-p (x)
 406   (or (<= (char-code #\a) (char-code x) (char-code #\z))
 407       (<= (char-code #\Z) (char-code x) (char-code #\Z))))
 408
 409 (defun digit-char-p (x)
 410   (if (and (<= (char-code #\0) (char-code x) (char-code #\9)))
 411       (- (char-code x) (char-code #\0))
 412       nil))
 413
 414 (defun digit-char (weight)
 415   (and (<= 0 weight 9)
 416        (char "0123456789" weight)))
 417
 418 (defun subseq (seq a &optional b)
 419   (if b
 420       (slice seq a b)
 421       (slice seq a)))
 422
 423 (defmacro do-sequence (iteration &body body)
 424   (let ((seq (gensym))
 425         (index (gensym)))
 426     `(let ((,seq ,(second iteration)))
 427        (cond
 428          ;; Strings
 429          ((stringp ,seq)
 430           (let ((,index 0))
 431             (dotimes (,index (length ,seq))
 432               (let ((,(first iteration)
 433                      (char ,seq ,index)))
 434                 ,@body))))
 435          ;; Lists
 436          ((listp ,seq)
 437           (dolist (,(first iteration) ,seq)
 438             ,@body))
 439          (t
 440           (error "type-error!"))))))
 441
 442 (defun find (item sequence &key (key #'identity) (test #'eql))
 443   (do-sequence (x sequence)
 444     (when (funcall test (funcall key x) item)
 445       (return x))))
 446
 447 (defun find-if (predicate sequence &key (key #'identity))
 448   (do-sequence (x sequence)
 449     (when (funcall predicate (funcall key x))
 450       (return x))))
 451
 452 (defun some (function seq)
 453   (do-sequence (elt seq)
 454     (when (funcall function elt)
 455       (return-from some t))))
 456
 457 (defun every (function seq)
 458   (do-sequence (elt seq)
 459     (unless (funcall function elt)
 460       (return-from every nil)))
 461   t)
 462
 463 (defun position (elt sequence)
 464   (let ((pos 0))
 465     (do-sequence (x seq)
 466       (when (eq elt x)
 467         (return))
 468       (incf pos))
 469     pos))
 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     ((stringp x)
 479      (and (stringp y) (string= x y)))
 480     (t nil)))
 481
 482 (defun fdefinition (x)
 483   (cond
 484     ((functionp x)
 485      x)
 486     ((symbolp x)
 487      (symbol-function x))
 488     (t
 489      (error "Invalid function `~S'." x))))
 490
 491 (defun disassemble (function)
 492   (write-line (lambda-code (fdefinition function)))
 493   nil)
 494
 495 (defun documentation (x type)
 496   "Return the documentation of X. TYPE must be the symbol VARIABLE or FUNCTION."
 497   (ecase type
 498     (function
 499      (let ((func (fdefinition x)))
 500        (oget func "docstring")))
 501     (variable
 502      (unless (symbolp x)
 503        (error "The type of documentation `~S' is not a symbol." type))
 504      (oget x "vardoc"))))
 505
 506 (defmacro multiple-value-bind (variables value-from &body body)
 507   `(multiple-value-call (lambda (&optional ,@variables &rest ,(gensym))
 508                           ,@body)
 509      ,value-from))
 510
 511 (defmacro multiple-value-list (value-from)
 512   `(multiple-value-call #'list ,value-from))
 513
 514
 515 ;;; Generalized references (SETF)
 516
 517 (defvar *setf-expanders* nil)
 518
 519 (defun get-setf-expansion (place)
 520   (if (symbolp place)
 521       (let ((value (gensym)))
 522         (values nil
 523                 nil
 524                 `(,value)
 525                 `(setq ,place ,value)
 526                 place))
 527       (let ((place (!macroexpand-1 place)))
 528         (let* ((access-fn (car place))
 529                (expander (cdr (assoc access-fn *setf-expanders*))))
 530           (when (null expander)
 531             (error "Unknown generalized reference."))
 532           (apply expander (cdr place))))))
 533
 534 (defmacro define-setf-expander (access-fn lambda-list &body body)
 535   (unless (symbolp access-fn)
 536     (error "ACCESS-FN `~S' must be a symbol." access-fn))
 537   `(progn (push (cons ',access-fn (lambda ,lambda-list ,@body))
 538                 *setf-expanders*)
 539           ',access-fn))
 540
 541 (defmacro setf (&rest pairs)
 542   (cond
 543     ((null pairs)
 544      nil)
 545     ((null (cdr pairs))
 546      (error "Odd number of arguments to setf."))
 547     ((null (cddr pairs))
 548      (let ((place (!macroexpand-1 (first pairs)))
 549            (value (second pairs)))
 550        (multiple-value-bind (vars vals store-vars writer-form)
 551            (get-setf-expansion place)
 552          ;; TODO: Optimize the expansion a little bit to avoid let*
 553          ;; or multiple-value-bind when unnecesary.
 554          `(let* ,(mapcar #'list vars vals)
 555             (multiple-value-bind ,store-vars
 556                 ,value
 557               ,writer-form)))))
 558     (t
 559      `(progn
 560         ,@(do ((pairs pairs (cddr pairs))
 561                (result '() (cons `(setf ,(car pairs) ,(cadr pairs)) result)))
 562               ((null pairs)
 563                (reverse result)))))))
 564
 565 ;; Incorrect typecase, but used in NCONC.
 566 (defmacro typecase (x &rest clausules)
 567   (let ((value (gensym)))
 568     `(let ((,value ,x))
 569        (cond
 570          ,@(mapcar (lambda (c)
 571                      (if (eq (car c) t)
 572                          `((t ,@(rest c)))
 573                          `((,(ecase (car c)
 574                                     (integer 'integerp)
 575                                     (cons 'consp)
 576                                     (symbol 'symbolp)
 577                                     (array 'arrayp)
 578                                     (string 'stringp)
 579                                     (atom 'atom)
 580                                     (null 'null))
 581                              ,value)
 582                            ,@(or (rest c)
 583                                  (list nil)))))
 584                    clausules)))))
 585
 586 (defmacro etypecase (x &rest clausules)
 587   (let ((g!x (gensym)))
 588     `(let ((,g!x ,x))
 589        (typecase ,g!x
 590          ,@clausules
 591          (t (error "~X fell through etypeacase expression." ,g!x))))))
 592
 593 (defun notany (fn seq)
 594   (not (some fn seq)))
 595
 596 (defconstant internal-time-units-per-second 1000)
 597
 598 (defun get-internal-real-time ()
 599   (get-internal-real-time))
 600
 601 (defun get-unix-time ()
 602   (truncate (/ (get-internal-real-time) 1000)))
 603
 604 (defun get-universal-time ()
 605   (+ (get-unix-time) 2208988800))
 606
 607 (defun concat (&rest strs)
 608   (!reduce #'concat-two strs ""))
 609
 610 (defun values-list (list)
 611   (values-array (list-to-vector list)))
 612
 613 (defun values (&rest args)
 614   (values-list args))
 615
 616 (defun error (fmt &rest args)
 617   (%throw (apply #'format nil fmt args)))
 618