/[cmucl]/src/code/macros.lisp
ViewVC logotype

Diff of /src/code/macros.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.50 by pw, Thu Jun 5 13:02:45 1997 UTC revision 1.50.2.3 by pw, Tue Jun 23 11:22:09 1998 UTC
# Line 982  Line 982 
982  (defsetf symbol-value set)  (defsetf symbol-value set)
983  (defsetf symbol-function fset)  (defsetf symbol-function fset)
984  (defsetf symbol-plist %set-symbol-plist)  (defsetf symbol-plist %set-symbol-plist)
 (defsetf documentation %set-documentation)  
985  (defsetf nth %setnth)  (defsetf nth %setnth)
986  (defsetf fill-pointer %set-fill-pointer)  (defsetf fill-pointer %set-fill-pointer)
987  (defsetf search-list %set-search-list)  (defsetf search-list %set-search-list)
# Line 1000  Line 999 
999  (defsetf sap-ref-sap %set-sap-ref-sap)  (defsetf sap-ref-sap %set-sap-ref-sap)
1000  (defsetf sap-ref-single %set-sap-ref-single)  (defsetf sap-ref-single %set-sap-ref-single)
1001  (defsetf sap-ref-double %set-sap-ref-double)  (defsetf sap-ref-double %set-sap-ref-double)
1002    #+long-float
1003    (defsetf sap-ref-long %set-sap-ref-long)
1004    
1005  (define-setf-method getf (place prop &optional default &environment env)  (define-setf-method getf (place prop &optional default &environment env)
1006    (multiple-value-bind (temps values stores set get)    (multiple-value-bind (temps values stores set get)
# Line 1392  Line 1393 
1393  (defmacro with-input-from-string ((var string &key index start end) &body (forms decls))  (defmacro with-input-from-string ((var string &key index start end) &body (forms decls))
1394    "Binds the Var to an input stream that returns characters from String and    "Binds the Var to an input stream that returns characters from String and
1395    executes the body.  See manual for details."    executes the body.  See manual for details."
1396    `(let ((,var    ;; The once-only inhibits compiler note for unreachable code when 'end' is true.
1397            ,(cond ((null end)    (once-only ((string string))
1398                    `(make-string-input-stream ,string ,(or start 0)))      `(let ((,var
1399                   ((symbolp end)              ,(cond ((null end)
1400                    `(if ,end                      `(make-string-input-stream ,string ,(or start 0)))
1401                         (make-string-input-stream ,string ,(or start 0) ,end)                     ((symbolp end)
1402                       (make-string-input-stream ,string ,(or start 0))))                      `(if ,end
1403                   (t                           (make-string-input-stream ,string ,(or start 0) ,end)
1404                    `(make-string-input-stream ,string ,(or start 0) ,end)))))                           (make-string-input-stream ,string ,(or start 0))))
1405       ,@decls                     (t
1406       (unwind-protect                      `(make-string-input-stream ,string ,(or start 0) ,end)))))
1407         (progn ,@forms)         ,@decls
1408         (close ,var)         (unwind-protect
1409         ,@(if index `((setf ,index (string-input-stream-current ,var)))))))             (progn ,@forms)
1410             (close ,var)
1411             ,@(if index `((setf ,index (string-input-stream-current ,var))))))))
1412    
1413    
1414  (defmacro with-output-to-string ((var &optional string) &body (forms decls))  (defmacro with-output-to-string ((var &optional string) &body (forms decls))
# Line 1466  Line 1469 
1469    Iteration construct.  Each Var is initialized in parallel to the value of the    Iteration construct.  Each Var is initialized in parallel to the value of the
1470    specified Init form.  On subsequent iterations, the Vars are assigned the    specified Init form.  On subsequent iterations, the Vars are assigned the
1471    value of the Step form (if any) in paralell.  The Test is evaluated before    value of the Step form (if any) in paralell.  The Test is evaluated before
1472    each evaluation of the body Forms.  When the Test is true, the the Exit-Forms    each evaluation of the body Forms.  When the Test is true, the Exit-Forms
1473    are evaluated as a PROGN, with the result being the value of the DO.  A block    are evaluated as a PROGN, with the result being the value of the DO.  A block
1474    named NIL is established around the entire expansion, allowing RETURN to be    named NIL is established around the entire expansion, allowing RETURN to be
1475    used as an laternate exit mechanism."    used as an laternate exit mechanism."
# Line 1480  Line 1483 
1483    value of the specified Init form.  On subsequent iterations, the Vars are    value of the specified Init form.  On subsequent iterations, the Vars are
1484    sequentially assigned the value of the Step form (if any).  The Test is    sequentially assigned the value of the Step form (if any).  The Test is
1485    evaluated before each evaluation of the body Forms.  When the Test is true,    evaluated before each evaluation of the body Forms.  When the Test is true,
1486    the the Exit-Forms are evaluated as a PROGN, with the result being the value    the Exit-Forms are evaluated as a PROGN, with the result being the value
1487    of the DO.  A block named NIL is established around the entire expansion,    of the DO.  A block named NIL is established around the entire expansion,
1488    allowing RETURN to be used as an laternate exit mechanism."    allowing RETURN to be used as an laternate exit mechanism."
1489    (do-do-body varlist endlist body decls 'let* 'setq 'do* nil))    (do-do-body varlist endlist body decls 'let* 'setq 'do* nil))
# Line 1497  Line 1500 
1500         (setqs nil)         (setqs nil)
1501         (pairs pairs (cddr pairs)))         (pairs pairs (cddr pairs)))
1502        ((atom (cdr pairs))        ((atom (cdr pairs))
1503         `(let ,(nreverse lets) (setq ,@(nreverse setqs))))         `(let ,(nreverse lets) (setq ,@(nreverse setqs)) nil))
1504      (let ((gen (gensym)))      (let ((gen (gensym)))
1505        (push `(,gen ,(cadr pairs)) lets)        (push `(,gen ,(cadr pairs)) lets)
1506        (push (car pairs) setqs)        (push (car pairs) setqs)

Legend:
Removed from v.1.50  
changed lines
  Added in v.1.50.2.3

  ViewVC Help
Powered by ViewVC 1.1.5