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