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