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