/[slime]/slime/swank-clisp.lisp
ViewVC logotype

Diff of /slime/swank-clisp.lisp

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

revision 1.39 by heller, Sun Oct 3 12:27:53 2004 UTC revision 1.40 by heller, Thu Oct 28 21:39:36 2004 UTC
# Line 492  Execute BODY with NAME's funtion slot se Line 492  Execute BODY with NAME's funtion slot se
492                                      (invoke-debugger condition)))))                                      (invoke-debugger condition)))))
493     nil))     nil))
494    
495    (in-package :system)
496    
497    #.(setf (ext:package-lock :system) nil)
498    
499    (ext:without-package-lock ()
500    
501    ;; Patch buggy format parser.  ~:,D was not parsed correcly.
502    (defun format-parse-cs (control-string startindex csdl stop-at)
503      (declare (fixnum startindex))
504      (macrolet ((errorstring ()
505                   (TEXT "The control string terminates within a format directive.")))
506        (prog* ((index startindex)  ; cs-index of the next character
507                ch                  ; current character
508                intparam            ; Integer-Parameter
509                newcsd              ; current CSD
510                (last-separator-csd (car csdl)))
511          (declare (type simple-string control-string) (type fixnum index))
512          (loop                     ; new directive altogether
513            (tagbody
514              (when (>= index (length control-string))
515                (go string-ended))
516              (setq ch (schar control-string index))
517              (unless (eql ch #\~)
518                ;; possibly transform part of string into a separate directive,
519                (setq csdl (setf (cdr csdl) (list (setq newcsd (make-csd)))))
520                (setf (csd-type     newcsd) 1)
521                (setf (csd-cs-index newcsd) index)
522                (setq index (position #\~ control-string :start index))
523                (unless index
524                  (setf (csd-data newcsd) (setq index (length control-string)))
525                  (go string-ended))
526                (setf (csd-data newcsd) index))
527              (setq csdl (setf (cdr csdl) (list (setq newcsd (make-csd)))))
528              (setf (csd-type         newcsd) 2)
529              (setf (csd-cs-index     newcsd) index)
530              (setf (csd-parm-list    newcsd) nil)
531              (setf (csd-v-or-#-p     newcsd) nil)
532              (setf (csd-colon-p      newcsd) nil)
533              (setf (csd-atsign-p     newcsd) nil)
534              (setf (csd-data         newcsd) nil)
535              (setf (csd-clause-chain newcsd) nil)
536    
537              param                 ; parameter of a directive may begin
538              (incf index)
539              (when (>= index (length control-string))
540                (format-error control-string index (errorstring))
541                (go string-ended))
542              (setq ch (schar control-string index))
543              (when (digit-char-p ch) (go num-param))
544              (case ch
545                ((#\+ #\-) (go num-param))
546                (#\' (go quote-param))
547                ((#\V #\v #\#)
548                 (push (if (eql ch #\#) ':ARG-COUNT ':NEXT-ARG)
549                       (csd-parm-list newcsd))
550                 (setf (csd-v-or-#-p newcsd) T)
551                 (go param-ok-1))
552                (#\, (push nil (csd-parm-list newcsd)) (go param))
553                (#\: (go colon-modifier))
554                (#\@ (go atsign-modifier))
555                (T (go directive)))
556    
557              num-param             ; numerical parameter
558              (multiple-value-setq (intparam index)
559                (parse-integer control-string :start index :junk-allowed t))
560              (unless intparam
561                (format-error control-string index
562                              (TEXT "~A must introduce a number.")
563                              ch))
564              (push intparam (csd-parm-list newcsd))
565              (go param-ok-2)
566    
567              quote-param           ; Quote-Parameter-Treatment
568              (incf index)
569              (when (>= index (length control-string))
570                (format-error control-string index
571                  (TEXT "The control string terminates in the middle of a parameter."))
572                (go string-ended))
573              (setq ch (schar control-string index))
574              (push ch (csd-parm-list newcsd))
575    
576              param-ok-1            ; Parameter OK
577              (incf index)
578              param-ok-2            ; Parameter OK
579              (when (>= index (length control-string))
580                (format-error control-string index (errorstring))
581                (go string-ended))
582              (setq ch (schar control-string index))
583              (case ch
584                (#\, (go param))
585                (#\: (go colon-modifier))
586                (#\@ (go atsign-modifier))
587                (T (go directive)))
588    
589              colon-modifier        ; after :
590              (when (csd-colon-p newcsd)
591                 (format-error control-string index
592                               (TEXT "Too many colon modifiers supplied")))
593              (setf (csd-colon-p newcsd) T)
594              (go param)
595    
596              atsign-modifier       ; after @
597              (when (csd-colon-p newcsd)
598                 (format-error control-string index
599                               (TEXT "Too many at modifiers supplied")))
600              (setf (csd-atsign-p newcsd) T)
601              (go param)
602    
603              directive             ; directive (its Name) reached
604              (setf (csd-parm-list newcsd) (nreverse (csd-parm-list newcsd)))
605              (let ((directive-name
606                      (cdr (assoc (char-upcase ch)
607                               ; with function-definition     ; without function-definition
608                             '((#\A . FORMAT-ASCII)
609                               (#\S . FORMAT-S-EXPRESSION)
610                               (#\W . FORMAT-WRITE)
611                               (#\D . FORMAT-DECIMAL)
612                               (#\B . FORMAT-BINARY)
613                               (#\O . FORMAT-OCTAL)
614                               (#\X . FORMAT-HEXADECIMAL)
615                               (#\R . FORMAT-RADIX)
616                               (#\P . FORMAT-PLURAL)
617                               (#\C . FORMAT-CHARACTER)
618                               (#\F . FORMAT-FIXED-FLOAT)
619                               (#\E . FORMAT-EXPONENTIAL-FLOAT)
620                               (#\G . FORMAT-GENERAL-FLOAT)
621                               (#\$ . FORMAT-DOLLARS-FLOAT)
622                               (#\% . FORMAT-TERPRI)
623                               (#\_ . FORMAT-PPRINT-NEWLINE)
624                               (#\I . FORMAT-PPRINT-INDENT)
625                               (#\& . FORMAT-FRESH-LINE)      (#\Newline . #\Newline)
626                               (#\| . FORMAT-PAGE)
627                               (#\~ . FORMAT-TILDE)
628                               (#\T . FORMAT-TABULATE)
629                               (#\* . FORMAT-GOTO)
630                               (#\? . FORMAT-INDIRECTION)
631                               (#\/ . FORMAT-CALL-USER-FUNCTION)
632                               (#\( . FORMAT-CASE-CONVERSION) (#\) . FORMAT-CASE-CONVERSION-END)
633                               (#\[ . FORMAT-CONDITIONAL)     (#\] . FORMAT-CONDITIONAL-END)
634                               (#\{ . FORMAT-ITERATION)       (#\} . FORMAT-ITERATION-END)
635                               (#\< . FORMAT-JUSTIFICATION)   (#\> . FORMAT-JUSTIFICATION-END)
636                               (#\^ . FORMAT-UP-AND-OUT)      (#\; . FORMAT-SEPARATOR)
637                               (#\! . FORMAT-CALL))))))
638                (if directive-name
639                  (setf (csd-data newcsd) directive-name)
640                  (format-error control-string index
641                    (TEXT "Non-existent format directive"))))
642              (incf index)
643              (case ch
644                (#\/
645                 (let* ((start index)
646                        (end (or (position #\/ control-string :start start)
647                                 (format-error control-string index
648                                   (TEXT "Closing '/' is missing"))))
649                        (pos (position #\: control-string :start start :end end))
650                        (name (string-upcase
651                                (subseq control-string
652                                        (if pos
653                                          (if (char= #\: (char control-string (1+ pos))) (+ 2 pos) (1+ pos))
654                                          start)
655                                        end)))
656                        (pack (if pos
657                                (let ((packname
658                                        (string-upcase
659                                          (subseq control-string start pos))))
660                                  (or (find-package packname)
661                                      (format-error control-string index
662                                        (TEXT "There is no package with name ~S")
663                                        packname)))
664                                *common-lisp-user-package*)))
665                   (push (list (intern name pack)) (csd-parm-list newcsd))
666                   (setq index (1+ end))))
667                (( #\( #\[ #\{)
668                 (multiple-value-setq (index csdl)
669                   (format-parse-cs control-string index csdl
670                     (case ch (#\( #\)) (#\[ #\]) (#\{ #\}) ))))
671                (#\<
672                 (multiple-value-setq (index csdl)
673                   (format-parse-cs control-string index csdl #\>))
674                 ;; (assert (eq (csd-data (car csdl)) 'FORMAT-JUSTIFICATION-END))
675                 (when (csd-colon-p (car csdl))
676                   (setf (csd-data newcsd) 'FORMAT-LOGICAL-BLOCK)))
677                (( #\) #\] #\} #\> )
678                 (unless stop-at
679                   (format-error control-string index
680                     (TEXT "The closing format directive '~A' does not have a corresponding opening one.")
681                     ch))
682                 (unless (eql ch stop-at)
683                   (format-error control-string index
684                     (TEXT "The closing format directive '~A' does not match the corresponding opening one. It should read '~A'.")
685                     ch stop-at))
686                 (setf (csd-clause-chain last-separator-csd) csdl)
687                 (go end))
688                (#\;
689                 (unless (or (eql stop-at #\]) (eql stop-at #\>))
690                   (format-error control-string index
691                     (TEXT "The ~~; format directive is not allowed at this point.")))
692                 (setf (csd-clause-chain last-separator-csd) csdl)
693                 (setq last-separator-csd newcsd))
694                (#\Newline
695                 (setf (csd-type newcsd) 0)
696                 (if (csd-colon-p newcsd)
697                   (if (csd-atsign-p newcsd)
698                     (format-error control-string index
699                       (TEXT "The ~~newline format directive cannot take both modifiers."))
700                     nil) ; ~:<newline> -> ignore Newline, retain Whitespace
701                   (progn
702                     (when (csd-atsign-p newcsd)
703                       ;; ~@<newline> -> part of String with Newline for output
704                       (setf (csd-type newcsd) 1)
705                       (setf (csd-cs-index newcsd) (1- index))
706                       (setf (csd-data newcsd) index))
707                     (setq index
708                       (or (position-if-not #'whitespacep control-string :start index)
709                           (length control-string)))))))
710            ) ; tagbody finished
711          )   ; loop finished
712    
713          string-ended
714          (when stop-at
715            (format-error control-string index
716              (TEXT "An opening format directive is never closed; expecting '~A'.")
717              stop-at))
718    
719          end
720          (return (values index csdl)))))
721    
722    )
723    
724    #.(setf (ext:package-lock :system) t)
725    
726    (in-package :swank-backend)
727    
728  ;;; Inspecting  ;;; Inspecting
729    
730  (defclass clisp-inspector (inspector)  (defclass clisp-inspector (inspector)

Legend:
Removed from v.1.39  
changed lines
  Added in v.1.40

  ViewVC Help
Powered by ViewVC 1.1.5